File Coverage

blib/lib/Net/WebSocket/PMCE/deflate/Data.pm
Criterion Covered Total %
statement 77 84 91.6
branch 10 18 55.5
condition 9 21 42.8
subroutine 18 20 90.0
pod 4 4 100.0
total 118 147 80.2


line stmt bran cond sub pod time code
1             package Net::WebSocket::PMCE::deflate::Data;
2              
3 3     3   1227 use strict;
  3         9  
  3         87  
4 3     3   19 use warnings;
  3         7  
  3         88  
5              
6 3     3   18 use parent qw( Net::WebSocket::PMCE::Data );
  3         7  
  3         19  
7              
8 3     3   829 use Module::Load ();
  3         2491  
  3         65  
9              
10 3     3   359 use Net::WebSocket::Message ();
  3         8  
  3         55  
11 3     3   719 use Net::WebSocket::PMCE::deflate::Constants ();
  3         8  
  3         104  
12              
13             use constant {
14 3         3837 _ZLIB_SYNC_TAIL => "\0\0\xff\xff",
15             _DEBUG => 0,
16 3     3   20 };
  3         6  
17              
18             =head2 I->new( %OPTS )
19              
20             %OPTS is:
21              
22             =over
23              
24             =item C - optional; the number of window bits to use
25             for compressing messages. This should correspond with the local endpoint’s
26             behavior; i.e., for a server, this should match the C
27             extension parameter in the WebSocket handshake.
28              
29             =item C - optional; the number of window bits to use
30             for decompressing messages. This should correspond with the remote peer’s
31             behavior; i.e., for a server, this should match the C
32             extension parameter in the WebSocket handshake.
33              
34             =item C - corresponds to either the
35             C or C parameter,
36             to match the local endpoint’s role. When this flag is set, the object
37             will do a full flush at the end of each C call.
38              
39             =back
40              
41             =cut
42              
43             sub new {
44 3     3 1 3431 my ($class, %opts) = @_;
45              
46             #Validate deflate_max_window_bits/inflate_max_window_bits?
47              
48 3         12 my $compress_func = '_compress_';
49 3 100       21 $compress_func .= $opts{'deflate_no_context_takeover'} ? 'full' : 'sync';
50 3         13 $compress_func .= '_flush_chomp';
51              
52 3         12 $opts{'final_frame_compress_func'} = $compress_func;
53              
54 3         18 return bless \%opts, $class;
55             }
56              
57             #----------------------------------------------------------------------
58              
59             =head2 $msg = I->create_message( FRAME_CLASS, PAYLOAD )
60              
61             Creates an unfragmented, compressed message. The message will be an
62             instance of the class that C
63             would instantiate; e.g., if FRAME_CLASS is C,
64             the message will be of type C.
65              
66             This method cannot be called while a streamer object has yet to create its
67             final frame.
68              
69             B This function alters PAYLOAD.
70              
71             =cut
72              
73             sub create_message {
74 0     0 1 0 my ($self, $frame_class) = @_; #$_[2] = payload
75              
76 0 0       0 die "A streamer is active!" if $self->{'_streamer_mode'};
77              
78 0         0 my $compress_func = $self->{'final_frame_compress_func'};
79              
80 0         0 my $payload_sr = \($self->$compress_func( $_[2] ));
81              
82 0         0 return Net::WebSocket::Message::create_from_frames(
83             $frame_class->new(
84             payload_sr => $payload_sr,
85             rsv => $self->INITIAL_FRAME_RSV(),
86             $self->FRAME_MASK_ARGS(),
87             ),
88             );
89             }
90              
91             #----------------------------------------------------------------------
92              
93             =head2 $msg = I->create_streamer( FRAME_CLASS )
94              
95             Returns an instance of L based
96             on this object.
97              
98             =cut
99              
100             sub create_streamer {
101 5     5 1 1386 my ($self, $frame_class) = @_;
102              
103 5         43 $self->{'_streamer_mode'} = 1;
104              
105 5         32 Module::Load::load('Net::WebSocket::PMCE::deflate::Data::Streamer');
106              
107 5         220 return Net::WebSocket::PMCE::deflate::Data::Streamer->new($self, $frame_class);
108             }
109              
110             #----------------------------------------------------------------------
111              
112             =head2 $decompressed = I->decompress( COMPRESSED_PAYLOAD )
113              
114             Decompresses the given string and returns the result.
115              
116             B This function alters COMPRESSED_PAYLOAD, such that
117             it’s probably not useful afterward.
118              
119             =cut
120              
121             #cf. RFC 7692, 7.2.2
122             sub decompress {
123 3     3 1 12 my ($self) = @_; #$_[1] = payload
124              
125 3   33     24 $self->{'i'} ||= $self->_create_inflate_obj();
126              
127 3         13 _DEBUG && _debug(sprintf "inflating: %v.02x\n", $_[1]);
128              
129 3         8 $_[1] .= _ZLIB_SYNC_TAIL;
130              
131 3         1585 my $status = $self->{'i'}->inflate($_[1], my $v);
132 3 50       16 die $status if $status != Compress::Raw::Zlib::Z_OK();
133              
134 3         20 _DEBUG && _debug(sprintf "inflate output: [%v.02x]\n", $v);
135              
136 3         365 return $v;
137             }
138              
139             #----------------------------------------------------------------------
140              
141             my $_payload_sr;
142              
143             #cf. RFC 7692, 7.2.1
144             #Use for non-final fragments.
145             sub _compress_non_final_fragment {
146 6   66 6   49 $_[0]->{'d'} ||= $_[0]->_create_deflate_obj();
147              
148 6         54 return $_[0]->_compress( $_[1] );
149             }
150              
151             #Preserves sliding window to the next message.
152             #Use for final fragments when deflate_no_context_takeover is OFF
153             sub _compress_sync_flush_chomp {
154 2   33 2   8 $_[0]->{'d'} ||= $_[0]->_create_deflate_obj();
155              
156 2         9 return _chomp_0000ffff_or_die( $_[0]->_compress( $_[1], Compress::Raw::Zlib::Z_SYNC_FLUSH() ) );
157             }
158              
159             #Flushes the sliding window.
160             #Use for final fragments when deflate_no_context_takeover is ON
161             sub _compress_full_flush_chomp {
162 3   33 3   13 $_[0]->{'d'} ||= $_[0]->_create_deflate_obj();
163              
164 3         17 return _chomp_0000ffff_or_die( $_[0]->_compress( $_[1], Compress::Raw::Zlib::Z_FULL_FLUSH() ) );
165             }
166              
167             sub _chomp_0000ffff_or_die {
168 5 50   5   28 if ( rindex( $_[0], _ZLIB_SYNC_TAIL ) == length($_[0]) - 4 ) {
169 5         16 substr($_[0], -4) = q<>;
170             }
171             else {
172 0         0 die sprintf('deflate/flush didn’t end with expected SYNC tail (00.00.ff.ff): %v.02x', $_[0]);
173             }
174              
175 5         19 return $_[0];
176             }
177              
178             sub _compress {
179 11     11   97 my ($self) = @_; # $_[1] = payload; $_[2] = flush method
180              
181 11         26 $_payload_sr = \$_[1];
182              
183 11         19 _DEBUG && _debug(sprintf "to deflate: [%v.02x]", $$_payload_sr);
184              
185 11         19 my $out;
186              
187 11         27055 my $dstatus = $self->{'d'}->deflate( $$_payload_sr, $out );
188 11 50       65 die "deflate: $dstatus" if $dstatus != Compress::Raw::Zlib::Z_OK();
189              
190 11         73 _DEBUG && _debug(sprintf "post-deflate output: [%v.02x]", $out);
191              
192 11 100       35 if ($_[2]) {
193 5         1056 $dstatus = $self->{'d'}->flush($out, $_[2]);
194 5 50       23 die "deflate flush: $dstatus" if $dstatus != Compress::Raw::Zlib::Z_OK();
195              
196 5         36 undef $self->{'_streamer_mode'};
197              
198 5         11 _DEBUG && _debug(sprintf "post-flush output: [%v.02x]", $out);
199             }
200              
201             #NB: The RFC directs at this point that:
202             #
203             #If the resulting data does not end with an empty DEFLATE block
204             #with no compression (the "BTYPE" bits are set to 00), append an
205             #empty DEFLATE block with no compression to the tail end.
206             #
207             #… but I don’t know the protocol well enough to detect that??
208             #
209             #NB:
210             #> perl -MCompress::Raw::Zlib -e' my $deflate = Compress::Raw::Zlib::Deflate->new( -WindowBits => -8, -AppendOutput => 1, -Level => Compress::Raw::Zlib::Z_NO_COMPRESSION ); $deflate->deflate( "", my $out ); $deflate->flush( $out, Compress::Raw::Zlib::Z_SYNC_FLUSH()); print $out' | xxd
211             #00000000: 0000 00ff ff .....
212              
213             # if ( $_[2] == Compress::Raw::Zlib::Z_FULL_FLUSH() ) {
214             # if ( substr($out, -4) eq _ZLIB_SYNC_TAIL ) {
215             # substr($out, -4) = q<>;
216             # }
217             # else {
218             # die sprintf('deflate/flush didn’t end with expected SYNC tail (00.00.ff.ff): %v.02x', $out);
219             # }
220             # }
221              
222 11         177 return $out;
223             }
224              
225             #----------------------------------------------------------------------
226              
227             my $zlib_is_loaded;
228              
229             sub _load_zlib_if_needed {
230 6   66 6   24 $zlib_is_loaded ||= do {
231 3         15 Module::Load::load('Compress::Raw::Zlib');
232 3         15857 1;
233             };
234              
235 6         12 return;
236             }
237              
238             sub _create_inflate_obj {
239 3     3   8 my ($self) = @_;
240              
241 3   33     20 my $window_bits = $self->{'inflate_max_window_bits'} || ( Net::WebSocket::PMCE::deflate::Constants::VALID_MAX_WINDOW_BITS() )[-1];
242              
243 3         9 _load_zlib_if_needed();
244              
245 3         23 my ($inflate, $istatus) = Compress::Raw::Zlib::Inflate->new(
246             -WindowBits => -$window_bits,
247             -AppendOutput => 1,
248             );
249 3 50       1170 die "Inflate: $istatus" if $istatus != Compress::Raw::Zlib::Z_OK();
250              
251 3         32 return $inflate;
252             }
253              
254             sub _create_deflate_obj {
255 3     3   10 my ($self) = @_;
256              
257 3   33     22 my $window_bits = $self->{'deflate_max_window_bits'} || ( Net::WebSocket::PMCE::deflate::Constants::VALID_MAX_WINDOW_BITS() )[-1];
258              
259 3         13 _load_zlib_if_needed();
260              
261 3         56 my ($deflate, $dstatus) = Compress::Raw::Zlib::Deflate->new(
262             -WindowBits => -$window_bits,
263             -AppendOutput => 1,
264             );
265 3 50       2098 die "Deflate: $dstatus" if $dstatus != Compress::Raw::Zlib::Z_OK();
266              
267 3         103 return $deflate;
268             }
269              
270             sub _debug {
271 0     0     print STDERR "$_[0]$/";
272             }
273              
274             1;