File Coverage

blib/lib/Net/WebSocket/Parser.pm
Criterion Covered Total %
statement 80 86 93.0
branch 33 38 86.8
condition 4 5 80.0
subroutine 10 10 100.0
pod 1 2 50.0
total 128 141 90.7


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::Read->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 only a partial frame is ready, undef is returned.
33              
34             =head1 I/O DETAILS
35              
36             L was born out of work on this module; see that module’s
37             documentation for the particulars of working with it. In particular,
38             note the exceptions L and
39             L. (As described in L’s
40             documentation, you can use an equivalent interface for frame chunking if you
41             wish.)
42              
43             =head1 CUSTOM FRAMES SUPPORT
44              
45             To support reception of custom frame types you’ll probably want to subclass
46             this module and define a specific custom constant for each supported opcode,
47             e.g.:
48              
49             package My::WebSocket::Parser;
50              
51             use parent qw( Net::WebSocket::Parser );
52              
53             use constant OPCODE_CLASS_3 => 'My::WebSocket::Frame::booya';
54              
55             … where C is itself a subclass of
56             C.
57              
58             You can also use this to override the default
59             classes for built-in frame types; e.g., C will override
60             L as the class will be used for pong frames
61             that this module receives. That could be useful, e.g., for compression
62             extensions, where you might want the C method to
63             decompress so that that detail is abstracted away.
64              
65             =cut
66              
67 6     6   394401 use strict;
  6         35  
  6         141  
68 6     6   29 use warnings;
  6         11  
  6         120  
69              
70 6     6   272 use Module::Load ();
  6         1137  
  6         73  
71              
72 6     6   1183 use Net::WebSocket::Constants ();
  6         12  
  6         88  
73 6     6   1066 use Net::WebSocket::X ();
  6         15  
  6         180  
74              
75             use constant {
76 6         3826 OPCODE_CLASS_0 => 'Net::WebSocket::Frame::continuation',
77             OPCODE_CLASS_1 => 'Net::WebSocket::Frame::text',
78             OPCODE_CLASS_2 => 'Net::WebSocket::Frame::binary',
79             OPCODE_CLASS_8 => 'Net::WebSocket::Frame::close',
80             OPCODE_CLASS_9 => 'Net::WebSocket::Frame::ping',
81             OPCODE_CLASS_10 => 'Net::WebSocket::Frame::pong',
82 6     6   29 };
  6         10  
83              
84             sub new {
85 21     21 0 18020 my ($class, $reader) = @_;
86              
87 21 50       133 if (!(ref $reader)->can('read')) {
88 0         0 die "“$reader” needs a read() method!";
89             }
90              
91 21         80 return bless {
92             _reader => $reader,
93             }, $class;
94             }
95              
96             sub get_next_frame {
97 65908     65908 1 3127352 my ($self) = @_;
98              
99 65908         81967 local $@;
100              
101 65908 100       118582 if (!exists $self->{'_partial_frame'}) {
102 21         44 $self->{'_partial_frame'} = q<>;
103             }
104              
105             #It is really, really inconvenient that Perl has no “or” operator
106             #that considers q<> falsey but '0' truthy. :-/
107             #That aside, if indeed all we read is '0', then we know that’s not
108             #enough, and we can return.
109 65908 100       99894 my $first2 = $self->_read_with_buffer(2) or return undef;
110              
111             #Now that we’ve read our header bytes, we’ll read some more.
112             #There may not actually be anything to read, though, in which case
113             #some readers will error (e.g., EAGAIN from a non-blocking filehandle).
114             #From a certain ideal we’d return #on each individual read to allow
115             #the reader to wait until there is more data ready; however, for
116             #practicality (and speed) let’s go ahead and try to read the rest of
117             #the frame. That means we need to set some flag to let the reader know
118             #not to die() if there’s no more data currently, as we’re probably
119             #expecting more soon to complete the frame.
120 65903         114728 local $self->{'_reading_frame'} = 1;
121              
122 65903         142348 my ($oct1, $oct2) = unpack('CC', $first2 );
123              
124 65903         94803 my $len = $oct2 & 0x7f;
125              
126 65903   100     106110 my $mask_size = ($oct2 & 0x80) && 4;
127              
128 65903 100       116093 my $len_len = ($len == 0x7e) ? 2 : ($len == 0x7f) ? 8 : 0;
    100          
129 65903         80414 my $len_buf = q<>;
130              
131 65903         78479 my ($longs, $long);
132              
133 65903 100       94740 if ($len_len) {
134 65804 100       100629 $len_buf = $self->_read_with_buffer($len_len) or do {
135 10         20 substr( $self->{'_partial_frame'}, 0, 0, $first2 );
136 10         31 return undef;
137             };
138              
139 65794 100       107219 if ($len_len == 2) {
140 257         572 ($longs, $long) = ( 0, unpack('n', $len_buf) );
141             }
142             else {
143 65537         120921 ($longs, $long) = ( unpack('NN', $len_buf) );
144             }
145             }
146             else {
147 99         167 ($longs, $long) = ( 0, $len );
148             }
149              
150 65893         78546 my $mask_buf;
151 65893 100       91887 if ($mask_size) {
152 71 100       125 $mask_buf = $self->_read_with_buffer($mask_size) or do {
153 4         14 substr( $self->{'_partial_frame'}, 0, 0, $first2 . $len_buf );
154 4         21 return undef;
155             };
156             }
157             else {
158 65822         83036 $mask_buf = q<>;
159             }
160              
161 65889         78519 my $payload = q<>;
162              
163 65889         113341 for ( 1 .. $longs ) {
164              
165             #32-bit systems don’t know what 2**32 is.
166             #MacOS, at least, also chokes on sysread( 2**31, … )
167             #(Is their size_t signed??), even on 64-bit.
168 0         0 for ( 1 .. 4 ) {
169 0 0       0 $self->_append_chunk( 2**30, \$payload ) or do {
170 0         0 substr( $self->{'_partial_frame'}, 0, 0, $first2 . $len_buf . $mask_buf . $payload );
171 0         0 return undef;
172             };
173             }
174             }
175              
176 65889 100       104289 if ($long) {
177 65881 100       110603 $self->_append_chunk( $long, \$payload ) or do {
178 65806         125769 substr( $self->{'_partial_frame'}, 0, 0, $first2 . $len_buf . $mask_buf . $payload );
179 65806         177609 return undef;
180             };
181             }
182              
183 83         140 $self->{'_partial_frame'} = q<>;
184              
185 83         123 my $opcode = $oct1 & 0xf;
186              
187 83   66     211 my $frame_class = $self->{'_opcode_class'}{$opcode} ||= do {
188 25         41 my $class;
189 25 50       140 if (my $cr = $self->can("OPCODE_CLASS_$opcode")) {
190 25         67 $class = $cr->();
191             }
192             else {
193              
194             #Untyped because this is a coding error.
195 0         0 die "$self: Unrecognized frame opcode: “$opcode”";
196             }
197              
198 25 100       235 Module::Load::load($class) if !$class->can('new');
199              
200 25         148 $class;
201             };
202              
203 83         320 return $frame_class->create_from_parse(\$first2, \$len_len, \$mask_buf, \$payload);
204             }
205              
206             #This will only return exactly the number of bytes requested.
207             #If fewer than we want are available, then we return undef.
208             sub _read_with_buffer {
209 197664     197664   257471 my ($self, $length) = @_;
210              
211             #Prioritize the case where we read everything we need.
212              
213 197664 100       321831 if ( length($self->{'_partial_frame'}) < $length ) {
214 66045         84878 my $deficit = $length - length($self->{'_partial_frame'});
215 66045         138862 my $read = $self->{'_reader'}->read($deficit);
216              
217 66044 100       1430842 if (!defined $read) {
218 65824         96744 return undef;
219             }
220              
221 220         668 return substr($self->{'_partial_frame'}, 0, length($self->{'_partial_frame'}), q<>) . $read;
222             }
223              
224 131619         325779 return substr( $self->{'_partial_frame'}, 0, $length, q<> );
225             }
226              
227             sub _append_chunk {
228 65881     65881   91866 my ($self, $length, $buf_sr) = @_;
229              
230 65881         83086 my $start_buf_len = length $$buf_sr;
231              
232 65881         75711 my $cur_buf;
233              
234 65881         72366 while (1) {
235 65881         79688 my $read_so_far = length($$buf_sr) - $start_buf_len;
236              
237 65881         107195 $cur_buf = $self->_read_with_buffer($length - $read_so_far);
238 65881 100       141342 return undef if !defined $cur_buf;
239              
240 75         187 $$buf_sr .= $cur_buf;
241              
242 75 50       160 last if (length($$buf_sr) - $start_buf_len) >= $length;
243             }
244              
245 75         147 return 1;
246             }
247              
248             1;