File Coverage

blib/lib/Net/WebSocket/Parser.pm
Criterion Covered Total %
statement 83 90 92.2
branch 39 50 78.0
condition 4 5 80.0
subroutine 10 10 100.0
pod 1 2 50.0
total 137 157 87.2


line stmt bran cond sub pod time code
1             package Net::WebSocket::Parser;
2              
3             =encoding utf-8
4              
5             =head1 NAME
6              
7             Net::WebSocket::Parser - Parse WebSocket from a filehandle
8              
9             =head1 SYNOPSIS
10              
11             my $iof = IO::Framed->new($fh);
12              
13             my $parse = Net::WebSocket::Parser->new($iof);
14              
15             #See below for error responses
16             my $frame = $parse->get_next_frame();
17              
18             C<$iof> should normally be an instance of L. You’re free to
19             pass in anything with a C method, but that method must implement
20             the same behavior as C.
21              
22             =head1 METHODS
23              
24             =head2 I->get_next_frame()
25              
26             A call to this method yields one of the following:
27              
28             =over
29              
30             =item * If a frame can be read, it will be returned.
31              
32             =item * If we hit an empty read (i.e., indicative of end-of-file),
33             empty string is returned.
34              
35             =item * If only a partial frame is ready, undef is returned.
36              
37             =back
38              
39             =head1 I/O DETAILS
40              
41             L was born out of work on this module; see that module’s
42             documentation for the particulars of working with it. In particular,
43             note the exceptions L and
44             L.
45              
46             Again, you can use an equivalent interface for frame chunking if you wish.
47              
48             =head1 CONCERNING EMPTY READS
49              
50             An empty read is how we detect that a file handle (or socket, etc.) has no
51             more data to read. Generally we shouldn’t get this in WebSocket since it
52             means that a peer endpoint has gone away without sending a close frame.
53             It is thus recommended that applications regard an empty read on a WebSocket
54             stream as an error condition; e.g., if you’re using L,
55             you should NOT enable the C behavior.
56              
57             Nevertheless, this module (and L) do work when
58             that flag is enabled.
59              
60             =head1 CUSTOM FRAMES SUPPORT
61              
62             To support reception of custom frame types you’ll probably want to subclass
63             this module and define a specific custom constant for each supported opcode,
64             e.g.:
65              
66             package My::WebSocket::Parser;
67              
68             use parent qw( Net::WebSocket::Parser );
69              
70             use constant OPCODE_CLASS_3 => 'My::WebSocket::Frame::booya';
71              
72             … where C is itself a subclass of
73             C.
74              
75             You can also use this to override the default
76             classes for built-in frame types; e.g., C will override
77             L as the class will be used for pong frames
78             that this module receives. That could be useful, e.g., for compression
79             extensions, where you might want the C method to
80             decompress so that that detail is abstracted away.
81              
82             =cut
83              
84 15     15   961048 use strict;
  15         110  
  15         475  
85 15     15   81 use warnings;
  15         31  
  15         377  
86              
87 15     15   618 use Module::Runtime ();
  15         1975  
  15         227  
88              
89 15     15   3460 use Net::WebSocket::Constants ();
  15         37  
  15         269  
90 15     15   3427 use Net::WebSocket::X ();
  15         44  
  15         565  
91              
92             use constant {
93 15         13786 OPCODE_CLASS_0 => 'Net::WebSocket::Frame::continuation',
94             OPCODE_CLASS_1 => 'Net::WebSocket::Frame::text',
95             OPCODE_CLASS_2 => 'Net::WebSocket::Frame::binary',
96             OPCODE_CLASS_8 => 'Net::WebSocket::Frame::close',
97             OPCODE_CLASS_9 => 'Net::WebSocket::Frame::ping',
98             OPCODE_CLASS_10 => 'Net::WebSocket::Frame::pong',
99 15     15   106 };
  15         39  
100              
101             sub new {
102 38     38 0 38825 my ($class, $reader) = @_;
103              
104 38 50       340 if (!(ref $reader)->can('read')) {
105 0         0 die "“$reader” needs a read() method!";
106             }
107              
108 38         308 return bless {
109             _reader => $reader,
110             _partial_frame => q<>,
111             }, $class;
112             }
113              
114             #Create these out here so that we don’t create/destroy them on each frame.
115             #As long as we don’t access them prior to writing to them this is fine.
116             my ($oct1, $oct2, $len, $mask_size, $len_len, $longs, $long);
117              
118             sub get_next_frame {
119 65933     65933 1 4690658 my ($self) = @_;
120              
121 65933         110790 local $@;
122              
123             #It is really, really inconvenient that Perl has no “or” operator
124             #that considers q<> falsey but '0' truthy. :-/
125             #That aside, if indeed all we read is '0', then we know that’s not
126             #enough, and we can return.
127 65933         119240 my $first2 = $self->_read_with_buffer(2);
128 65933 100       132360 if (!$first2) {
129 6 100       36 return defined($first2) ? q<> : undef;
130             }
131              
132 65927         170009 ($oct1, $oct2) = unpack('CC', $first2 );
133              
134 65927         115554 $len = $oct2 & 0x7f;
135              
136 65927   100     124838 $mask_size = ($oct2 & 0x80) && 4;
137              
138 65927 100       140332 $len_len = ($len == 0x7e) ? 2 : ($len == 0x7f) ? 8 : 0;
    100          
139              
140 65927         101925 my ($len_buf, $mask_buf);
141              
142 65927 100       106386 if ($len_len) {
143 65810         113664 $len_buf = $self->_read_with_buffer($len_len);
144              
145 65810 100       127311 if (!$len_buf) {
146 10         20 substr( $self->{'_partial_frame'}, 0, 0, $first2 );
147 10 50       33 return defined($len_buf) ? q<> : undef;
148             };
149              
150 65800 100       114609 if ($len_len == 2) {
151 259         608 ($longs, $long) = ( 0, unpack('n', $len_buf) );
152             }
153             else {
154              
155             #Do it this way to support 32-bit systems.
156 65541         146725 ($longs, $long) = ( unpack('NN', $len_buf) );
157             }
158             }
159             else {
160 117         199 ($longs, $long) = ( 0, $len );
161 117         189 $len_buf = q<>;
162             }
163              
164 65917 100       118281 if ($mask_size) {
165 72         138 $mask_buf = $self->_read_with_buffer($mask_size);
166 72 100       169 if (!$mask_buf) {
167 4         11 substr( $self->{'_partial_frame'}, 0, 0, $first2 . $len_buf );
168 4 50       16 return defined($mask_buf) ? q<> : undef;
169             };
170             }
171             else {
172 65845         93494 $mask_buf = q<>;
173             }
174              
175 65913         92738 my $payload = q<>;
176              
177 65913         156613 for ( 1 .. $longs ) {
178              
179             #32-bit systems don’t know what 2**32 is.
180             #MacOS, at least, also chokes on sysread( 2**31, … )
181             #(Is their size_t signed??), even on 64-bit.
182 0         0 for ( 1 .. 4 ) {
183 0         0 my $append_ok = $self->_append_chunk( 2**30, \$payload );
184 0 0       0 if (!$append_ok) {
185 0         0 substr( $self->{'_partial_frame'}, 0, 0, $first2 . $len_buf . $mask_buf . $payload );
186 0 0       0 return defined($append_ok) ? q<> : undef;
187             };
188             }
189             }
190              
191 65913 100       116633 if ($long) {
192 65905         124790 my $append_ok = $self->_append_chunk( $long, \$payload );
193 65905 100       127947 if (!$append_ok) {
194 65806         156808 substr( $self->{'_partial_frame'}, 0, 0, $first2 . $len_buf . $mask_buf . $payload );
195 65806 50       195827 return defined($append_ok) ? q<> : undef;
196             }
197             }
198              
199 107         192 $self->{'_partial_frame'} = q<>;
200              
201 107         193 my $opcode = $oct1 & 0xf;
202              
203 107   66     382 my $frame_class = $self->{'_opcode_class'}{$opcode} ||= do {
204 44         79 my $class;
205 44 50       287 if (my $cr = $self->can("OPCODE_CLASS_$opcode")) {
206 44         139 $class = $cr->();
207             }
208             else {
209              
210             #Untyped because this is a coding error.
211 0         0 die "$self: Unrecognized frame opcode: “$opcode”";
212             }
213              
214 44 100       487 Module::Runtime::require_module($class) if !$class->can('new');
215              
216 44         200 $class;
217             };
218              
219 107         518 return $frame_class->create_from_parse(\$first2, \$len_buf, \$mask_buf, \$payload);
220             }
221              
222             # This will only return exactly the number of bytes requested.
223             # If fewer than we want are available, then we return undef.
224             # This incorporates the partial-frame buffer, which keeps get_next_frame()
225             # a bit simpler than it otherwise might be.
226             #
227             sub _read_with_buffer {
228 197720     197720   297279 my ($self, $length) = @_;
229              
230             # Prioritize the case where we have everything we need.
231             # This will happen if, e.g., we got a partial frame on first read
232             # and a subsequent read has to pick back up.
233              
234 197720 100       381893 if ( length($self->{'_partial_frame'}) < $length ) {
235 66101         97740 my $deficit = $length - length($self->{'_partial_frame'});
236 66101         179852 my $read = $self->{'_reader'}->read($deficit);
237              
238 66101 100       2860606 if (!defined $read) {
    100          
239 65824         120398 return undef;
240             }
241             elsif (!length $read) {
242 2         7 return q<>;
243             }
244              
245 275         1635 return substr($self->{'_partial_frame'}, 0, length($self->{'_partial_frame'}), q<>) . $read;
246             }
247              
248 131619         316628 return substr( $self->{'_partial_frame'}, 0, $length, q<> );
249             }
250              
251             sub _append_chunk {
252 65905     65905   109111 my ($self, $length, $buf_sr) = @_;
253              
254 65905         92170 my $start_buf_len = length $$buf_sr;
255              
256 65905         87525 my $cur_buf;
257              
258 65905         84443 while (1) {
259 65905         90956 my $read_so_far = length($$buf_sr) - $start_buf_len;
260              
261 65905         115120 $cur_buf = $self->_read_with_buffer($length - $read_so_far);
262 65905 100       173521 return undef if !defined $cur_buf;
263              
264 99 50       290 return q<> if !length $cur_buf;
265              
266 99         593 $$buf_sr .= $cur_buf;
267              
268 99 50       329 last if (length($$buf_sr) - $start_buf_len) >= $length;
269             }
270              
271 99         209 return 1;
272             }
273              
274             1;