File Coverage

blib/lib/Net/WebSocket/Frame.pm
Criterion Covered Total %
statement 61 123 49.5
branch 15 30 50.0
condition 4 7 57.1
subroutine 14 28 50.0
pod 0 17 0.0
total 94 205 45.8


line stmt bran cond sub pod time code
1             package Net::WebSocket::Frame;
2              
3             =encoding utf-8
4              
5             =head1 NAME
6              
7             Net::WebSocket::Frame
8              
9             =head1 SYNOPSIS
10              
11             #Never instantiate Net::WebSocket::Frame directly;
12             #always call new() on a subclass:
13             my $frame = Net::WebSocket::Frame::text->new(
14             fin => 0, #to start a fragmented message
15             rsv => 0b11, #RSV2 and RSV3 are on
16             mask => "\x01\x02\x03\x04 #clients MUST include; servers MUST NOT
17             payload_sr => \'Woot!',
18             );
19              
20             $frame->get_fin();
21             $frame->get_mask_bytes();
22             $frame->get_payload();
23              
24             $frame->set_rsv();
25             $frame->get_rsv();
26              
27             $frame->to_bytes(); #for sending over the wire
28              
29             =head1 DESCRIPTION
30              
31             This is the base class for all frame objects. The interface as described
32             above should be fairly straightforward.
33              
34             =head1 EXPERIMENTAL: CUSTOM FRAME CLASSES
35              
36             You can have custom frame classes, e.g., to support WebSocket extensions that
37             use custom frame opcodes. RFC 6455 allocates opcodes 3-7 for data frames and
38             11-15 (0xb - 0xf) for control frames.
39              
40             The best way to do this is to subclass either
41             L or L,
42             depending on what kind of frame you’re dealing with.
43              
44             An example of such a class is below:
45              
46             package My::Custom::Frame::booya;
47              
48             use strict;
49             use warnings;
50              
51             use parent qw( Net::WebSocket::Base::DataFrame );
52              
53             use constant get_opcode => 3;
54              
55             use constant get_type => 'booya';
56              
57             Note that L still won’t know how to handle such a
58             custom frame, so if you intend to receive custom frames as part of messages,
59             you’ll also need to create a custom base class of this class, then also
60             subclass L. You may additionally want to subclass
61             L (or -C<::Client>) if you do streaming.
62              
63             B I’m not familiar with any application that
64             actually requires this feature. The C extension seems to
65             be the only one that has much widespread web browser support.
66              
67             =cut
68              
69 9     9   50993 use strict;
  9         21  
  9         224  
70 9     9   44 use warnings;
  9         17  
  9         199  
71              
72 9     9   1279 use Net::WebSocket::Constants ();
  9         18  
  9         137  
73 9     9   1167 use Net::WebSocket::Mask ();
  9         19  
  9         134  
74 9     9   874 use Net::WebSocket::X ();
  9         20  
  9         370  
75              
76             use constant {
77 9         10865 FIRST2 => 0,
78             LEN_LEN => 1,
79             MASK => 2,
80             PAYLOAD => 3,
81              
82             _RSV1 => chr(4 << 4),
83             _RSV2 => chr(2 << 4),
84             _RSV3 => chr(1 << 4),
85 9     9   43 };
  9         17  
86              
87             #fin, rsv, mask, payload_sr
88             #rsv is a bitmask of the three values, with RSV1 as MOST significant bit.
89             #So, represent RSV1 and RSV2 being on via 0b110 (= 4 + 2 = 6)
90             sub new {
91 65     65 0 212 my ($class, %opts) = @_;
92              
93 65         152 my ( $fin, $rsv, $mask, $payload_sr ) = @opts{ qw( fin rsv mask payload_sr ) };
94              
95 65         168 my $type = $class->get_type();
96              
97 65         188 my $opcode = $class->get_opcode($type);
98              
99 65 100       143 if (!defined $fin) {
100 6         13 $fin = 1;
101             }
102              
103 65   100     124 $payload_sr ||= \do { my $v = q<> };
  2         8  
104              
105 65         158 my ($byte2, $len_len) = $class->_assemble_length($payload_sr);
106              
107 65 100       119 if (defined $mask) {
108 53         103 _validate_mask($mask);
109              
110 53 50       80 if (length $mask) {
111 53         77 $byte2 |= "\x80";
112 53         86 Net::WebSocket::Mask::apply($payload_sr, $mask);
113             }
114             }
115             else {
116 12         27 $mask = q<>;
117             }
118              
119 65         98 my $first2 = chr $opcode;
120 65 100       122 $first2 |= "\x80" if $fin;
121              
122 65 100       108 if ($rsv) {
123 5 50       14 die "“rsv” must be < 0-7!" if $rsv > 7;
124 5         16 $first2 |= chr( $rsv << 4 );
125             }
126              
127 65         95 substr( $first2, 1, 0, $byte2 );
128              
129 65         262 return bless [ \$first2, \$len_len, \$mask, $payload_sr ], $class;
130             }
131              
132             sub set_payload_sr {
133 0     0 0 0 my ($self, $new_payload_sr) = @_;
134              
135 0         0 my ($byte2, $len_len) = $self->_assemble_length($new_payload_sr);
136              
137 0 0       0 if (length ${ $self->[2] }) {
  0         0  
138 0         0 $byte2 |= "\x80";
139 0         0 Net::WebSocket::Mask::apply($new_payload_sr, ${ $self->[2] });
  0         0  
140             }
141              
142 0         0 substr( ${ $self->[0] }, 1, 1, $byte2 );
  0         0  
143 0         0 @{$self}[1, 3] = (\$len_len, $new_payload_sr);
  0         0  
144              
145 0         0 return $self;
146             }
147              
148             # All string refs: first2, length octets, mask octets, payload
149             sub create_from_parse {
150 83     83 0 361 return bless \@_, shift;
151             }
152              
153             sub get_mask_bytes {
154 95     95 0 213 my ($self) = @_;
155              
156 95         115 return ${ $self->[MASK] };
  95         259  
157             }
158              
159             #To collect the goods
160             sub get_payload {
161 94     94 0 1205 my ($self) = @_;
162              
163 94         119 my $pl = "" . ${ $self->[PAYLOAD] };
  94         329  
164              
165 94 100       207 if (my $mask = $self->get_mask_bytes()) {
166 58         128 Net::WebSocket::Mask::apply( \$pl, $mask );
167             }
168              
169 94         669 return $pl;
170             }
171              
172             #For sending over the wire
173             sub to_bytes {
174 59     59 0 102 my ($self) = @_;
175              
176 59         109 return join( q<>, map { $$_ } @$self );
  236         866  
177             }
178              
179             sub get_rsv {
180 0     0 0 0 my ($self) = @_;
181              
182             #0b01110000 = 0x70
183 0         0 return( ord( substr( ${ $self->[FIRST2] }, 0, 1 ) & "\x70" ) >> 4 );
  0         0  
184             }
185              
186             sub set_rsv {
187 0     0 0 0 my ($self, $rsv) = @_;
188              
189 0         0 ${ $self->[FIRST2] } |= chr( $rsv << 4 );
  0         0  
190              
191 0         0 return $self;
192             }
193              
194             sub set_rsv1 {
195 0     0 0 0 ${ $_[0][FIRST2] } |= _RSV1();
  0         0  
196              
197 0         0 return $_[0];
198             }
199              
200             sub set_rsv2 {
201 0     0 0 0 ${ $_[0][FIRST2] } |= _RSV2();
  0         0  
202              
203 0         0 return $_[0];
204             }
205              
206             sub set_rsv3 {
207 0     0 0 0 ${ $_[0][FIRST2] } |= _RSV3();
  0         0  
208              
209 0         0 return $_[0];
210             }
211              
212             sub has_rsv1 {
213 0     0 0 0 return ("\0\0" ne (${ $_[0][FIRST2] } & _RSV1()));
  0         0  
214             }
215              
216             sub has_rsv2 {
217 0     0 0 0 return ("\0\0" ne (${ $_[0][FIRST2] } & _RSV2()));
  0         0  
218             }
219              
220             sub has_rsv3 {
221 0     0 0 0 return ("\0\0" ne (${ $_[0][FIRST2] } & _RSV3()));
  0         0  
222             }
223              
224             #----------------------------------------------------------------------
225             #Redundancies with methods in DataFrame.pm and ControlFrame.pm.
226             #These are here so that we don’t have to re-bless in order to get this
227             #information.
228              
229             sub is_control_frame {
230 0     0 0 0 my ($self) = @_;
231              
232             #8 == 0b1000 == 010
233 0 0       0 return( ($self->_extract_opcode() & 8) ? 1 : 0 );
234             }
235              
236             sub get_fin {
237 7     7 0 13 my ($self) = @_;
238              
239 7   100     9 return( ord ("\x80" & ${$self->[$self->FIRST2]}) && 1 );
240             }
241              
242             #----------------------------------------------------------------------
243              
244             #sub get_opcode {
245             # my ($class) = @_;
246             #
247             # die "$class (type “$type”) must define a custom get_opcode() method!";
248             #}
249              
250             #----------------------------------------------------------------------
251              
252             #Unneeded?
253             #sub set_mask_bytes {
254             # my ($self, $bytes) = @_;
255             #
256             # if (!defined $bytes) {
257             # die "Set either a 4-byte mask, or empty string!";
258             # }
259             #
260             # if (length $bytes) {
261             # _validate_mask($bytes);
262             #
263             # $self->_activate_highest_bit( $self->[FIRST2], 1 );
264             # }
265             # else {
266             # $self->_deactivate_highest_bit( $self->[FIRST2], 1 );
267             # }
268             #
269             # if (${ $self->[MASK] }) {
270             # Net::WebSocket::Mask::apply( $self->[PAYLOAD], ${ $self->[MASK] } );
271             # }
272             #
273             # $self->[MASK] = \$bytes;
274             #
275             # if ($bytes) {
276             # Net::WebSocket::Mask::apply( $self->[PAYLOAD], $bytes );
277             # }
278             #
279             # return $self;
280             #}
281              
282             #----------------------------------------------------------------------
283              
284             sub opcode_to_type {
285 0     0 0 0 my ($class, $opcode) = @_;
286 0         0 return Net::WebSocket::Constants::opcode_to_type($opcode);
287             }
288              
289             our $AUTOLOAD;
290             sub AUTOLOAD {
291 148     148   19949 my ($self) = shift;
292              
293 148 50       1173 return if substr( $AUTOLOAD, -8 ) eq ':DESTROY';
294              
295 0         0 my $last_colon_idx = rindex( $AUTOLOAD, ':' );
296 0         0 my $method = substr( $AUTOLOAD, 1 + $last_colon_idx );
297              
298             #Figure out what type this is, and re-bless.
299 0 0       0 if (ref($self) eq __PACKAGE__) {
300 0         0 my $opcode = $self->_extract_opcode();
301 0         0 my $type = $self->opcode_to_type($opcode);
302              
303 0         0 my $class = __PACKAGE__ . "::$type";
304 0 0       0 if (!$class->can('new')) {
305 0         0 Module::Load::load($class);
306             }
307              
308 0         0 bless $self, $class;
309              
310 0 0       0 if ($self->can($method)) {
311 0         0 return $self->$method(@_);
312             }
313             }
314              
315 0   0     0 my $class = (ref $self) || $self;
316              
317 0         0 die( "$class has no method “$method”!" );
318             }
319              
320             #----------------------------------------------------------------------
321              
322             sub _extract_opcode {
323 0     0   0 my ($self) = @_;
324              
325 0         0 return 0xf & ord substr( ${ $self->[FIRST2] }, 0, 1 );
  0         0  
326             }
327              
328             sub _validate_mask {
329 53     53   71 my ($bytes) = @_;
330              
331 53 50       86 if (length $bytes) {
332 53 50       86 if (4 != length $bytes) {
333 0         0 my $len = length $bytes;
334 0         0 die "Mask must be 4 bytes long, not $len ($bytes)!";
335             }
336             }
337              
338 53         65 return;
339             }
340              
341             sub _activate_highest_bit {
342 0     0     my ($self, $sr, $offset) = @_;
343              
344 0           substr( $$sr, $offset, 1 ) = chr( 0x80 | ord substr( $$sr, $offset, 1 ) );
345              
346 0           return;
347             }
348              
349             sub _deactivate_highest_bit {
350 0     0     my ($sr, $offset) = @_;
351              
352 0           substr( $$sr, $offset, 1 ) = chr( 0x7f & ord substr( $$sr, $offset, 1 ) );
353              
354 0           return;
355             }
356              
357             1;