File Coverage

blib/lib/Net/WebSocket/Frame.pm
Criterion Covered Total %
statement 58 96 60.4
branch 14 30 46.6
condition 4 7 57.1
subroutine 14 21 66.6
pod 0 10 0.0
total 90 164 54.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 6     6   49377 use strict;
  6         13  
  6         151  
70 6     6   29 use warnings;
  6         12  
  6         137  
71              
72 6     6   450 use Net::WebSocket::Constants ();
  6         11  
  6         91  
73 6     6   1323 use Net::WebSocket::Mask ();
  6         13  
  6         118  
74 6     6   431 use Net::WebSocket::X ();
  6         12  
  6         159  
75              
76             use constant {
77 6         5752 FIRST2 => 0,
78             LEN_LEN => 1,
79             MASK => 2,
80             PAYLOAD => 3,
81 6     6   30 };
  6         19  
82              
83             #fin, rsv, mask, payload_sr
84             #rsv is a bitmask of the three values, with RSV1 as MOST significant bit.
85             #So, represent RSV1 and RSV2 being on via 0b110 (= 4 + 2 = 6)
86             sub new {
87 59     59 0 157 my ($class, %opts) = @_;
88              
89 59         133 my ( $fin, $rsv, $mask, $payload_sr ) = @opts{ qw( fin rsv mask payload_sr ) };
90              
91 59         137 my $type = $class->get_type();
92              
93 59         142 my $opcode = $class->get_opcode($type);
94              
95 59 50       106 if (!defined $fin) {
96 0         0 $fin = 1;
97             }
98              
99 59   100     105 $payload_sr ||= \do { my $v = q<> };
  2         8  
100              
101 59 100       94 if (defined $mask) {
102 53         115 _validate_mask($mask);
103              
104 53 50       105 if (length $mask) {
105 53         107 Net::WebSocket::Mask::apply($payload_sr, $mask);
106             }
107             }
108             else {
109 6         11 $mask = q<>;
110             }
111              
112 59         94 my $first2 = chr $opcode;
113 59 100       109 $first2 |= "\x80" if $fin;
114              
115 59 50       93 if ($rsv) {
116 0 0       0 die "“rsv” must be < 0-7!" if $rsv > 7;
117 0         0 $first2 |= chr( $rsv << 4 );
118             }
119              
120 59         137 my ($byte2, $len_len) = $class->_assemble_length($payload_sr);
121              
122 59 100       122 $byte2 |= "\x80" if $mask;
123              
124 59         86 substr( $first2, 1, 0, $byte2 );
125              
126 59         210 return bless [ \$first2, \$len_len, \$mask, $payload_sr ], $class;
127             }
128              
129             # All string refs: first2, length octets, mask octets, payload
130             sub create_from_parse {
131 83     83 0 352 return bless \@_, shift;
132             }
133              
134             sub get_mask_bytes {
135 81     81 0 180 my ($self) = @_;
136              
137 81         103 return ${ $self->[MASK] };
  81         201  
138             }
139              
140             #To collect the goods
141             sub get_payload {
142 80     80 0 483 my ($self) = @_;
143              
144 80         104 my $pl = "" . ${ $self->[PAYLOAD] };
  80         229  
145              
146 80 100       167 if (my $mask = $self->get_mask_bytes()) {
147 58         122 Net::WebSocket::Mask::apply( \$pl, $mask );
148             }
149              
150 80         391 return $pl;
151             }
152              
153             #For sending over the wire
154             sub to_bytes {
155 59     59 0 110 my ($self) = @_;
156              
157 59         103 return join( q<>, map { $$_ } @$self );
  236         967  
158             }
159              
160             sub get_rsv {
161 0     0 0 0 my ($self) = @_;
162              
163             #0b01110000 = 0x70
164 0         0 return( ord( substr( ${ $self->[FIRST2] }, 0, 1 ) & "\x70" ) >> 4 );
  0         0  
165             }
166              
167             sub set_rsv {
168 0     0 0 0 my ($self, $rsv) = @_;
169              
170 0         0 ${ $self->[FIRST2] } |= chr( $rsv << 4 );
  0         0  
171              
172 0         0 return $self;
173             }
174              
175             #----------------------------------------------------------------------
176             #Redundancies with methods in DataFrame.pm and ControlFrame.pm.
177             #These are here so that we don’t have to re-bless in order to get this
178             #information.
179              
180             sub is_control_frame {
181 0     0 0 0 my ($self) = @_;
182              
183             #8 == 0b1000 == 010
184 0 0       0 return( ($self->_extract_opcode() & 8) ? 1 : 0 );
185             }
186              
187             sub get_fin {
188 7     7 0 12 my ($self) = @_;
189              
190 7   100     9 return( ord ("\x80" & ${$self->[$self->FIRST2]}) && 1 );
191             }
192              
193             #----------------------------------------------------------------------
194              
195             #sub get_opcode {
196             # my ($class) = @_;
197             #
198             # die "$class (type “$type”) must define a custom get_opcode() method!";
199             #}
200              
201             #----------------------------------------------------------------------
202              
203             #Unneeded?
204             #sub set_mask_bytes {
205             # my ($self, $bytes) = @_;
206             #
207             # if (!defined $bytes) {
208             # die "Set either a 4-byte mask, or empty string!";
209             # }
210             #
211             # if (length $bytes) {
212             # _validate_mask($bytes);
213             #
214             # $self->_activate_highest_bit( $self->[FIRST2], 1 );
215             # }
216             # else {
217             # $self->_deactivate_highest_bit( $self->[FIRST2], 1 );
218             # }
219             #
220             # if (${ $self->[MASK] }) {
221             # Net::WebSocket::Mask::apply( $self->[PAYLOAD], ${ $self->[MASK] } );
222             # }
223             #
224             # $self->[MASK] = \$bytes;
225             #
226             # if ($bytes) {
227             # Net::WebSocket::Mask::apply( $self->[PAYLOAD], $bytes );
228             # }
229             #
230             # return $self;
231             #}
232              
233             #----------------------------------------------------------------------
234              
235             sub opcode_to_type {
236 0     0 0 0 my ($class, $opcode) = @_;
237 0         0 return Net::WebSocket::Constants::opcode_to_type($opcode);
238             }
239              
240             our $AUTOLOAD;
241             sub AUTOLOAD {
242 142     142   18890 my ($self) = shift;
243              
244 142 50       750 return if substr( $AUTOLOAD, -8 ) eq ':DESTROY';
245              
246 0         0 my $last_colon_idx = rindex( $AUTOLOAD, ':' );
247 0         0 my $method = substr( $AUTOLOAD, 1 + $last_colon_idx );
248              
249             #Figure out what type this is, and re-bless.
250 0 0       0 if (ref($self) eq __PACKAGE__) {
251 0         0 my $opcode = $self->_extract_opcode();
252 0         0 my $type = $self->opcode_to_type($opcode);
253              
254 0         0 my $class = __PACKAGE__ . "::$type";
255 0 0       0 if (!$class->can('new')) {
256 0         0 Module::Load::load($class);
257             }
258              
259 0         0 bless $self, $class;
260              
261 0 0       0 if ($self->can($method)) {
262 0         0 return $self->$method(@_);
263             }
264             }
265              
266 0   0     0 my $class = (ref $self) || $self;
267              
268 0         0 die( "$class has no method “$method”!" );
269             }
270              
271             #----------------------------------------------------------------------
272              
273             sub _extract_opcode {
274 0     0   0 my ($self) = @_;
275              
276 0         0 return 0xf & ord substr( ${ $self->[FIRST2] }, 0, 1 );
  0         0  
277             }
278              
279             sub _validate_mask {
280 53     53   77 my ($bytes) = @_;
281              
282 53 50       89 if (length $bytes) {
283 53 50       93 if (4 != length $bytes) {
284 0         0 my $len = length $bytes;
285 0         0 die "Mask must be 4 bytes long, not $len ($bytes)!";
286             }
287             }
288              
289 53         70 return;
290             }
291              
292             sub _activate_highest_bit {
293 0     0     my ($self, $sr, $offset) = @_;
294              
295 0           substr( $$sr, $offset, 1 ) = chr( 0x80 | ord substr( $$sr, $offset, 1 ) );
296              
297 0           return;
298             }
299              
300             sub _deactivate_highest_bit {
301 0     0     my ($sr, $offset) = @_;
302              
303 0           substr( $$sr, $offset, 1 ) = chr( 0x7f & ord substr( $$sr, $offset, 1 ) );
304              
305 0           return;
306             }
307              
308             1;