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 21     21   64415 use strict;
  21         51  
  21         463  
70 21     21   80 use warnings;
  21         36  
  21         475  
71              
72 21         114 use parent qw(
73             Net::WebSocket::Base::Typed
74 21     21   443 );
  21         251  
75              
76 21     21   5211 use Net::WebSocket::Constants ();
  21         40  
  21         314  
77 21     21   5428 use Net::WebSocket::Mask ();
  21         41  
  21         292  
78 21     21   4202 use Net::WebSocket::X ();
  21         41  
  21         805  
79              
80             use constant {
81 21         21546 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 21     21   101 };
  21         30  
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 103     103 0 4708 my $class = shift;
96              
97 103         151 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 103         220 while (@_) {
103 246         291 my $key = shift;
104              
105             #“payload_sr” (as a named argument) is legacy
106 246 100 66     701 if ($key eq 'payload' || $key eq 'payload_sr') {
    100          
    100          
    50          
107 101 100       218 if (!ref $_[0]) {
    50          
108 42 50       77 if (defined $_[0]) {
109 42         109 $payload_sr = \shift;
110             }
111             else {
112 0         0 shift;
113 0         0 next;
114             }
115             }
116             elsif ('SCALAR' eq ref $_[0]) {
117 59         106 $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 84         177 $fin = shift;
125             }
126             elsif ($key eq 'rsv') {
127 6         16 $rsv = shift;
128             }
129             elsif ($key eq 'mask') {
130 55         97 $mask = shift;
131             }
132             else {
133 0         0 warn sprintf("Unrecognized argument “%s” (%s)", $key, shift);
134             }
135             }
136              
137 103         347 my $type = $class->get_type();
138              
139 103         280 my $opcode = $class->get_opcode($type);
140              
141 103 100       237 if (!defined $fin) {
142 19         55 $fin = 1;
143             }
144              
145 103   100     186 $payload_sr ||= \do { my $v = q<> };
  2         6  
146              
147 103         292 my ($byte2, $len_len) = $class->_assemble_length($payload_sr);
148              
149 103 100       204 if (defined $mask) {
150 55         94 _validate_mask($mask);
151              
152 55 50       76 if (length $mask) {
153 55         72 $byte2 |= "\x80";
154 55         97 Net::WebSocket::Mask::apply($payload_sr, $mask);
155             }
156             }
157             else {
158 48         70 $mask = q<>;
159             }
160              
161 103         156 my $first2 = chr $opcode;
162 103 100       213 $first2 |= "\x80" if $fin;
163              
164 103 100       200 if ($rsv) {
165 5 50       16 die "“rsv” must be < 0-7!" if $rsv > 7;
166 5         37 $first2 |= chr( $rsv << 4 );
167             }
168              
169 103         157 substr( $first2, 1, 0, $byte2 );
170              
171 103         404 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 105     105 0 389 return bless \@_, shift;
177             }
178              
179             sub get_mask_bytes {
180 120     120 0 4957 my ($self) = @_;
181              
182 120         165 return ${ $self->[MASK] };
  120         315  
183             }
184              
185             #To collect the goods
186             sub get_payload {
187 116     116 0 7928 my ($self) = @_;
188              
189 116         148 my $pl = "" . ${ $self->[PAYLOAD] };
  116         646  
190              
191 116 100       290 if (my $mask = $self->get_mask_bytes()) {
192 64         132 Net::WebSocket::Mask::apply( \$pl, $mask );
193             }
194              
195 116         1256 return $pl;
196             }
197              
198             #For sending over the wire
199             sub to_bytes {
200 104     104 0 5007 my ($self) = @_;
201              
202 104         241 return join( q<>, map { $$_ } @$self );
  416         2074  
203             }
204              
205             sub get_rsv {
206 9     9 0 21 my ($self) = @_;
207              
208             #0b01110000 = 0x70
209 9         9 return( ord( substr( ${ $self->[FIRST2] }, 0, 1 ) & "\x70" ) >> 4 );
  9         38  
210             }
211              
212             my $rsv;
213             sub set_rsv {
214 10     10 0 2807 $rsv = $_[1];
215              
216             #Consider the first byte as a vector of 4-bit segments.
217              
218 10 50       11 $rsv |= 8 if substr( ${ $_[0]->[FIRST2] }, 0, 1 ) & "\x80";
  10         36  
219              
220 10         14 vec( substr( ${ $_[0]->[FIRST2] }, 0, 1 ), 1, 4 ) = $rsv;
  10         40  
221              
222 10         20 return $_[0];
223             }
224              
225             sub set_rsv1 {
226 1     1 0 418 ${ $_[0][FIRST2] } |= _RSV1();
  1         4  
227              
228 1         3 return $_[0];
229             }
230              
231             sub set_rsv2 {
232 1     1 0 1 ${ $_[0][FIRST2] } |= _RSV2();
  1         4  
233              
234 1         2 return $_[0];
235             }
236              
237             sub set_rsv3 {
238 1     1 0 2 ${ $_[0][FIRST2] } |= _RSV3();
  1         2  
239              
240 1         16 return $_[0];
241             }
242              
243             sub has_rsv1 {
244 10     10 0 17 return ("\0" ne (${ $_[0][FIRST2] } & _RSV1()));
  10         44  
245             }
246              
247             sub has_rsv2 {
248 10     10 0 17 return ("\0" ne (${ $_[0][FIRST2] } & _RSV2()));
  10         45  
249             }
250              
251             sub has_rsv3 {
252 10     10 0 16 return ("\0" ne (${ $_[0][FIRST2] } & _RSV3()));
  10         41  
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   69 my ($bytes) = @_;
262              
263 55 50       85 if (length $bytes) {
264 55 50       81 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         77 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;