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 23     23   85261 use strict;
  23         58  
  23         667  
70 23     23   118 use warnings;
  23         64  
  23         695  
71              
72 23         184 use parent qw(
73             Net::WebSocket::Base::Typed
74 23     23   608 );
  23         393  
75              
76 23     23   7026 use Net::WebSocket::Constants ();
  23         56  
  23         411  
77 23     23   7762 use Net::WebSocket::Mask ();
  23         56  
  23         423  
78 23     23   6320 use Net::WebSocket::X ();
  23         60  
  23         1191  
79              
80             use constant {
81 23         29739 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 23     23   136 };
  23         44  
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 139     139 0 6272 my $class = shift;
96              
97 139         235 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 139         385 while (@_) {
103 318         458 my $key = shift;
104              
105             #“payload_sr” (as a named argument) is legacy
106 318 100 66     1151 if ($key eq 'payload' || $key eq 'payload_sr') {
    100          
    100          
    50          
107 137 100       337 if (!ref $_[0]) {
    50          
108 78 50       153 if (defined $_[0]) {
109 78         222 $payload_sr = \shift;
110             }
111             else {
112 0         0 shift;
113 0         0 next;
114             }
115             }
116             elsif ('SCALAR' eq ref $_[0]) {
117 59         119 $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 120         270 $fin = shift;
125             }
126             elsif ($key eq 'rsv') {
127 6         17 $rsv = shift;
128             }
129             elsif ($key eq 'mask') {
130 55         119 $mask = shift;
131             }
132             else {
133 0         0 warn sprintf("Unrecognized argument “%s” (%s)", $key, shift);
134             }
135             }
136              
137 139         530 my $type = $class->get_type();
138              
139 139         463 my $opcode = $class->get_opcode($type);
140              
141 139 100       335 if (!defined $fin) {
142 19         37 $fin = 1;
143             }
144              
145 139   100     311 $payload_sr ||= \do { my $v = q<> };
  2         8  
146              
147 139         418 my ($byte2, $len_len) = $class->_assemble_length($payload_sr);
148              
149 139 100       316 if (defined $mask) {
150 55         126 _validate_mask($mask);
151              
152 55 50       98 if (length $mask) {
153 55         97 $byte2 |= "\x80";
154 55         113 Net::WebSocket::Mask::apply($payload_sr, $mask);
155             }
156             }
157             else {
158 84         167 $mask = q<>;
159             }
160              
161 139         345 my $first2 = chr $opcode;
162 139 100       350 $first2 |= "\x80" if $fin;
163              
164 139 100       308 if ($rsv) {
165 5 50       11 die "“rsv” must be < 0-7!" if $rsv > 7;
166 5         16 $first2 |= chr( $rsv << 4 );
167             }
168              
169 139         271 substr( $first2, 1, 0, $byte2 );
170              
171 139         710 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 107     107 0 555 return bless \@_, shift;
177             }
178              
179             sub get_mask_bytes {
180 149     149 0 15117 my ($self) = @_;
181              
182 149         215 return ${ $self->[MASK] };
  149         461  
183             }
184              
185             #To collect the goods
186             sub get_payload {
187 144     144 0 10480 my ($self) = @_;
188              
189 144         217 my $pl = "" . ${ $self->[PAYLOAD] };
  144         668  
190              
191 144 100       455 if (my $mask = $self->get_mask_bytes()) {
192 60         152 Net::WebSocket::Mask::apply( \$pl, $mask );
193             }
194              
195 144         1843 return $pl;
196             }
197              
198             #For sending over the wire
199             sub to_bytes {
200 106     106 0 2241 my ($self) = @_;
201              
202 106         299 return join( q<>, map { $$_ } @$self );
  424         2730  
203             }
204              
205             sub get_rsv {
206 9     9 0 23 my ($self) = @_;
207              
208             #0b01110000 = 0x70
209 9         14 return( ord( substr( ${ $self->[FIRST2] }, 0, 1 ) & "\x70" ) >> 4 );
  9         53  
210             }
211              
212             my $rsv;
213             sub set_rsv {
214 10     10 0 3554 $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         48  
219              
220 10         16 vec( substr( ${ $_[0]->[FIRST2] }, 0, 1 ), 1, 4 ) = $rsv;
  10         55  
221              
222 10         26 return $_[0];
223             }
224              
225             sub set_rsv1 {
226 1     1 0 891 ${ $_[0][FIRST2] } |= _RSV1();
  1         5  
227              
228 1         4 return $_[0];
229             }
230              
231             sub set_rsv2 {
232 1     1 0 3 ${ $_[0][FIRST2] } |= _RSV2();
  1         4  
233              
234 1         4 return $_[0];
235             }
236              
237             sub set_rsv3 {
238 1     1 0 3 ${ $_[0][FIRST2] } |= _RSV3();
  1         5  
239              
240 1         22 return $_[0];
241             }
242              
243             sub has_rsv1 {
244 10     10 0 22 return ("\0" ne (${ $_[0][FIRST2] } & _RSV1()));
  10         61  
245             }
246              
247             sub has_rsv2 {
248 10     10 0 20 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         58  
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   84 my ($bytes) = @_;
262              
263 55 50       114 if (length $bytes) {
264 55 50       154 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         78 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;