File Coverage

blib/lib/Net/WebSocket/Frame.pm
Criterion Covered Total %
statement 94 107 87.8
branch 26 34 76.4
condition 4 5 80.0
subroutine 21 24 87.5
pod 0 14 0.0
total 145 184 78.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 => \'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 24     24   91604 use strict;
  24         66  
  24         733  
70 24     24   118 use warnings;
  24         44  
  24         712  
71              
72 24         166 use parent qw(
73             Net::WebSocket::Base::Typed
74 24     24   584 );
  24         392  
75              
76 24     24   7334 use Net::WebSocket::Constants ();
  24         59  
  24         443  
77 24     24   8267 use Net::WebSocket::Mask ();
  24         61  
  24         462  
78 24     24   6495 use Net::WebSocket::X ();
  24         63  
  24         1151  
79              
80             use constant {
81 24         31490 FIRST2 => 0,
82             LEN_LEN => 1,
83             MASK => 2,
84             PAYLOAD => 3,
85              
86             _RSV1 => chr(4 << 4),
87             _RSV2 => chr(2 << 4),
88             _RSV3 => chr(1 << 4),
89 24     24   142 };
  24         52  
90              
91             #fin, rsv, mask, payload
92             #rsv is a bitmask of the three values, with RSV1 as MOST significant bit.
93             #So, represent RSV1 and RSV2 being on via 0b110 (= 4 + 2 = 6)
94             sub new {
95 140     140 0 6359 my $class = shift;
96              
97 140         264 my ( $fin, $rsv, $mask, $payload_sr );
98              
99             #We loop through like this so that we can get a nice
100             #syntax for “payload” without copying the string.
101             #This logic should be equivalent to a hash.
102 140         367 while (@_) {
103 320         471 my $key = shift;
104              
105             #“payload_sr” (as a named argument) is legacy
106 320 100 66     1144 if ($key eq 'payload' || $key eq 'payload_sr') {
    100          
    100          
    50          
107 138 100       348 if (!ref $_[0]) {
    50          
108 79 50       161 if (defined $_[0]) {
109 79         230 $payload_sr = \shift;
110             }
111             else {
112 0         0 shift;
113 0         0 next;
114             }
115             }
116             elsif ('SCALAR' eq ref $_[0]) {
117 59         123 $payload_sr = shift;
118             }
119             else {
120 0         0 die Net::WebSocket::X->create('BadArg', $key => shift, 'Must be a scalar or SCALAR reference.');
121             }
122             }
123             elsif ($key eq 'fin') {
124 121         293 $fin = shift;
125             }
126             elsif ($key eq 'rsv') {
127 6         43 $rsv = shift;
128             }
129             elsif ($key eq 'mask') {
130 55         159 $mask = shift;
131             }
132             else {
133 0         0 warn sprintf("Unrecognized argument “%s” (%s)", $key, shift);
134             }
135             }
136              
137 140         599 my $type = $class->get_type();
138              
139 140         502 my $opcode = $class->get_opcode($type);
140              
141 140 100       368 if (!defined $fin) {
142 19         36 $fin = 1;
143             }
144              
145 140   100     334 $payload_sr ||= \do { my $v = q<> };
  2         10  
146              
147 140         462 my ($byte2, $len_len) = $class->_assemble_length($payload_sr);
148              
149 140 100       348 if (defined $mask) {
150 55         130 _validate_mask($mask);
151              
152 55 50       106 if (length $mask) {
153 55         123 $byte2 |= "\x80";
154 55         114 Net::WebSocket::Mask::apply($payload_sr, $mask);
155             }
156             }
157             else {
158 85         140 $mask = q<>;
159             }
160              
161 140         265 my $first2 = chr $opcode;
162 140 100       355 $first2 |= "\x80" if $fin;
163              
164 140 100       293 if ($rsv) {
165 5 50       15 die "“rsv” must be < 0-7!" if $rsv > 7;
166 5         13 $first2 |= chr( $rsv << 4 );
167             }
168              
169 140         271 substr( $first2, 1, 0, $byte2 );
170              
171 140         719 return bless [ \$first2, \$len_len, \$mask, $payload_sr ], $class;
172             }
173              
174             # All string refs: first2, length octets, mask octets, payload
175             sub create_from_parse {
176 109     109 0 559 return bless \@_, shift;
177             }
178              
179             sub get_mask_bytes {
180 150     150 0 20395 my ($self) = @_;
181              
182 150         212 return ${ $self->[MASK] };
  150         479  
183             }
184              
185             #To collect the goods
186             sub get_payload {
187 144     144 0 10678 my ($self) = @_;
188              
189 144         229 my $pl = "" . ${ $self->[PAYLOAD] };
  144         700  
190              
191 144 100       390 if (my $mask = $self->get_mask_bytes()) {
192 60         172 Net::WebSocket::Mask::apply( \$pl, $mask );
193             }
194              
195 144         1770 return $pl;
196             }
197              
198             #For sending over the wire
199             sub to_bytes {
200 107     107 0 2145 my ($self) = @_;
201              
202 107         323 return join( q<>, map { $$_ } @$self );
  428         2882  
203             }
204              
205             sub get_rsv {
206 9     9 0 25 my ($self) = @_;
207              
208             #0b01110000 = 0x70
209 9         15 return( ord( substr( ${ $self->[FIRST2] }, 0, 1 ) & "\x70" ) >> 4 );
  9         52  
210             }
211              
212             my $rsv;
213             sub set_rsv {
214 10     10 0 3529 $rsv = $_[1];
215              
216             #Consider the first byte as a vector of 4-bit segments.
217              
218 10 50       17 $rsv |= 8 if substr( ${ $_[0]->[FIRST2] }, 0, 1 ) & "\x80";
  10         46  
219              
220 10         21 vec( substr( ${ $_[0]->[FIRST2] }, 0, 1 ), 1, 4 ) = $rsv;
  10         52  
221              
222 10         29 return $_[0];
223             }
224              
225             sub set_rsv1 {
226 1     1 0 562 ${ $_[0][FIRST2] } |= _RSV1();
  1         6  
227              
228 1         3 return $_[0];
229             }
230              
231             sub set_rsv2 {
232 1     1 0 2 ${ $_[0][FIRST2] } |= _RSV2();
  1         5  
233              
234 1         3 return $_[0];
235             }
236              
237             sub set_rsv3 {
238 1     1 0 2 ${ $_[0][FIRST2] } |= _RSV3();
  1         4  
239              
240 1         17 return $_[0];
241             }
242              
243             sub has_rsv1 {
244 10     10 0 24 return ("\0" ne (${ $_[0][FIRST2] } & _RSV1()));
  10         59  
245             }
246              
247             sub has_rsv2 {
248 10     10 0 19 return ("\0" ne (${ $_[0][FIRST2] } & _RSV2()));
  10         57  
249             }
250              
251             sub has_rsv3 {
252 10     10 0 20 return ("\0" ne (${ $_[0][FIRST2] } & _RSV3()));
  10         55  
253             }
254              
255             #pre-0.064 compatibility
256 0     0 0 0 sub is_control_frame { return $_[0]->is_control() }
257              
258             #----------------------------------------------------------------------
259              
260             sub _validate_mask {
261 55     55   93 my ($bytes) = @_;
262              
263 55 50       103 if (length $bytes) {
264 55 50       106 if (4 != length $bytes) {
265 0         0 my $len = length $bytes;
266 0         0 die "Mask must be 4 bytes long, not $len ($bytes)!";
267             }
268             }
269              
270 55         88 return;
271             }
272              
273             sub _activate_highest_bit {
274 0     0     my ($self, $sr, $offset) = @_;
275              
276 0           substr( $$sr, $offset, 1 ) = chr( 0x80 | ord substr( $$sr, $offset, 1 ) );
277              
278 0           return;
279             }
280              
281             sub _deactivate_highest_bit {
282 0     0     my ($sr, $offset) = @_;
283              
284 0           substr( $$sr, $offset, 1 ) = chr( 0x7f & ord substr( $$sr, $offset, 1 ) );
285              
286 0           return;
287             }
288              
289             1;