File Coverage

blib/lib/Compress/Raw/Zlib.pm
Criterion Covered Total %
statement 198 227 87.2
branch 73 102 71.5
condition 25 41 60.9
subroutine 35 41 85.3
pod 0 1 0.0
total 331 412 80.3


line stmt bran cond sub pod time code
1              
2             package Compress::Raw::Zlib;
3              
4             require 5.006 ;
5             require Exporter;
6 6     6   91065 use Carp ;
  6         44  
  6         724  
7              
8 6     6   47 use strict ;
  6         12  
  6         145  
9 6     6   29 use warnings ;
  6         12  
  6         163  
10 6     6   1916 use bytes ;
  6         51  
  6         28  
11             our ($VERSION, $XS_VERSION, @ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD, %DEFLATE_CONSTANTS, @DEFLATE_CONSTANTS);
12              
13             $VERSION = '2.205';
14             $XS_VERSION = $VERSION;
15             $VERSION = eval $VERSION;
16              
17             @ISA = qw(Exporter);
18             %EXPORT_TAGS = ( flush => [qw{
19             Z_NO_FLUSH
20             Z_PARTIAL_FLUSH
21             Z_SYNC_FLUSH
22             Z_FULL_FLUSH
23             Z_FINISH
24             Z_BLOCK
25             }],
26             level => [qw{
27             Z_NO_COMPRESSION
28             Z_BEST_SPEED
29             Z_BEST_COMPRESSION
30             Z_DEFAULT_COMPRESSION
31             }],
32             strategy => [qw{
33             Z_FILTERED
34             Z_HUFFMAN_ONLY
35             Z_RLE
36             Z_FIXED
37             Z_DEFAULT_STRATEGY
38             }],
39             status => [qw{
40             Z_OK
41             Z_STREAM_END
42             Z_NEED_DICT
43             Z_ERRNO
44             Z_STREAM_ERROR
45             Z_DATA_ERROR
46             Z_MEM_ERROR
47             Z_BUF_ERROR
48             Z_VERSION_ERROR
49             }],
50             );
51              
52             %DEFLATE_CONSTANTS = %EXPORT_TAGS;
53              
54             # Items to export into callers namespace by default. Note: do not export
55             # names by default without a very good reason. Use EXPORT_OK instead.
56             # Do not simply export all your public functions/methods/constants.
57             @DEFLATE_CONSTANTS =
58             @EXPORT = qw(
59             ZLIB_VERSION
60             ZLIB_VERNUM
61              
62              
63             OS_CODE
64              
65             MAX_MEM_LEVEL
66             MAX_WBITS
67              
68             Z_ASCII
69             Z_BEST_COMPRESSION
70             Z_BEST_SPEED
71             Z_BINARY
72             Z_BLOCK
73             Z_BUF_ERROR
74             Z_DATA_ERROR
75             Z_DEFAULT_COMPRESSION
76             Z_DEFAULT_STRATEGY
77             Z_DEFLATED
78             Z_ERRNO
79             Z_FILTERED
80             Z_FIXED
81             Z_FINISH
82             Z_FULL_FLUSH
83             Z_HUFFMAN_ONLY
84             Z_MEM_ERROR
85             Z_NEED_DICT
86             Z_NO_COMPRESSION
87             Z_NO_FLUSH
88             Z_NULL
89             Z_OK
90             Z_PARTIAL_FLUSH
91             Z_RLE
92             Z_STREAM_END
93             Z_STREAM_ERROR
94             Z_SYNC_FLUSH
95             Z_TREES
96             Z_UNKNOWN
97             Z_VERSION_ERROR
98              
99             ZLIBNG_VERSION
100             ZLIBNG_VERNUM
101             ZLIBNG_VER_MAJOR
102             ZLIBNG_VER_MINOR
103             ZLIBNG_VER_REVISION
104             ZLIBNG_VER_STATUS
105             ZLIBNG_VER_MODIFIED
106              
107             WANT_GZIP
108             WANT_GZIP_OR_ZLIB
109             );
110              
111             push @EXPORT, qw(crc32 adler32 DEF_WBITS);
112              
113 6     6   1631 use constant WANT_GZIP => 16;
  6         20  
  6         751  
114 6     6   73 use constant WANT_GZIP_OR_ZLIB => 32;
  6         17  
  6         820  
115              
116             sub AUTOLOAD {
117 57     57   4224 my($constname);
118 57         376 ($constname = $AUTOLOAD) =~ s/.*:://;
119 57         422 my ($error, $val) = constant($constname);
120 57 50       181 Carp::croak $error if $error;
121 6     6   51 no strict 'refs';
  6         13  
  6         641  
122 57     1854   219 *{$AUTOLOAD} = sub { $val };
  57         237  
  1854         23471  
123 57         107 goto &{$AUTOLOAD};
  57         213  
124             }
125              
126 6     6   49 use constant FLAG_APPEND => 1 ;
  6         13  
  6         341  
127 6     6   49 use constant FLAG_CRC => 2 ;
  6         11  
  6         310  
128 6     6   42 use constant FLAG_ADLER => 4 ;
  6         11  
  6         273  
129 6     6   35 use constant FLAG_CONSUME_INPUT => 8 ;
  6         11  
  6         322  
130 6     6   38 use constant FLAG_LIMIT_OUTPUT => 16 ;
  6         9  
  6         847  
131              
132             eval {
133             require XSLoader;
134             XSLoader::load('Compress::Raw::Zlib', $XS_VERSION);
135             1;
136             }
137             or do {
138             require DynaLoader;
139             local @ISA = qw(DynaLoader);
140             bootstrap Compress::Raw::Zlib $XS_VERSION ;
141             };
142              
143              
144 6     6   61 use constant Parse_any => 0x01;
  6         22  
  6         331  
145 6     6   36 use constant Parse_unsigned => 0x02;
  6         11  
  6         403  
146 6     6   48 use constant Parse_signed => 0x04;
  6         17  
  6         404  
147 6     6   45 use constant Parse_boolean => 0x08;
  6         9  
  6         306  
148             #use constant Parse_string => 0x10;
149             #use constant Parse_custom => 0x12;
150              
151             #use constant Parse_store_ref => 0x100 ;
152              
153 6     6   33 use constant OFF_PARSED => 0 ;
  6         12  
  6         283  
154 6     6   34 use constant OFF_TYPE => 1 ;
  6         11  
  6         284  
155 6     6   51 use constant OFF_DEFAULT => 2 ;
  6         24  
  6         297  
156 6     6   38 use constant OFF_FIXED => 3 ;
  6         17  
  6         315  
157 6     6   44 use constant OFF_FIRST_ONLY => 4 ;
  6         16  
  6         280  
158 6     6   39 use constant OFF_STICKY => 5 ;
  6         13  
  6         16894  
159              
160              
161              
162             sub ParseParameters
163             {
164 97   50 97 0 404 my $level = shift || 0 ;
165              
166 97         694 my $sub = (caller($level + 1))[3] ;
167             #local $Carp::CarpLevel = 1 ;
168 97         319 my $p = new Compress::Raw::Zlib::Parameters() ;
169 97 100       234 $p->parse(@_)
170             or croak "$sub: $p->{Error}" ;
171              
172 86         180 return $p;
173             }
174              
175              
176             sub Compress::Raw::Zlib::Parameters::new
177             {
178 97     97   158 my $class = shift ;
179              
180 97         306 my $obj = { Error => '',
181             Got => {},
182             } ;
183              
184             #return bless $obj, ref($class) || $class || __PACKAGE__ ;
185 97         256 return bless $obj, 'Compress::Raw::Zlib::Parameters' ;
186             }
187              
188             sub Compress::Raw::Zlib::Parameters::setError
189             {
190 11     11   21 my $self = shift ;
191 11         15 my $error = shift ;
192 11 50       23 my $retval = @_ ? shift : undef ;
193              
194 11         18 $self->{Error} = $error ;
195 11         1363 return $retval;
196             }
197              
198             #sub getError
199             #{
200             # my $self = shift ;
201             # return $self->{Error} ;
202             #}
203              
204             sub Compress::Raw::Zlib::Parameters::parse
205             {
206 97     97   137 my $self = shift ;
207              
208 97         149 my $default = shift ;
209              
210 97         186 my $got = $self->{Got} ;
211 97         137 my $firstTime = keys %{ $got } == 0 ;
  97         262  
212              
213 97         175 my (@Bad) ;
214 97         170 my @entered = () ;
215              
216             # Allow the options to be passed as a hash reference or
217             # as the complete hash.
218 97 100       286 if (@_ == 0) {
    100          
219 11         26 @entered = () ;
220             }
221             elsif (@_ == 1) {
222 9         13 my $href = $_[0] ;
223 9 100 66     72 return $self->setError("Expected even number of parameters, got 1")
      66        
224             if ! defined $href or ! ref $href or ref $href ne "HASH" ;
225              
226 7         33 foreach my $key (keys %$href) {
227 14         24 push @entered, $key ;
228 14         32 push @entered, \$href->{$key} ;
229             }
230             }
231             else {
232 77         173 my $count = @_;
233 77 100       249 return $self->setError("Expected even number of parameters, got $count")
234             if $count % 2 != 0 ;
235              
236 75         267 for my $i (0.. $count / 2 - 1) {
237 120         244 push @entered, $_[2* $i] ;
238 120         278 push @entered, \$_[2* $i+1] ;
239             }
240             }
241              
242              
243 93         380 while (my ($key, $v) = each %$default)
244             {
245 780 50       1510 croak "need 4 params [@$v]"
246             if @$v != 4 ;
247              
248 780         1358 my ($first_only, $sticky, $type, $value) = @$v ;
249 780         976 my $x ;
250 780 50       1468 $self->_checkType($key, \$value, $type, 0, \$x)
251             or return undef ;
252              
253 780         1435 $key = lc $key;
254              
255 780 50 33     1440 if ($firstTime || ! $sticky) {
256 780         2214 $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
257             }
258              
259 780         2505 $got->{$key}[OFF_PARSED] = 0 ;
260             }
261              
262 93         313 for my $i (0.. @entered / 2 - 1) {
263 134         259 my $key = $entered[2* $i] ;
264 134         211 my $value = $entered[2* $i+1] ;
265              
266             #print "Key [$key] Value [$value]" ;
267             #print defined $$value ? "[$$value]\n" : "[undef]\n";
268              
269 134         501 $key =~ s/^-// ;
270 134         256 my $canonkey = lc $key;
271              
272 134 100 33     561 if ($got->{$canonkey} && ($firstTime ||
      66        
273             ! $got->{$canonkey}[OFF_FIRST_ONLY] ))
274             {
275 131         280 my $type = $got->{$canonkey}[OFF_TYPE] ;
276 131         174 my $s ;
277 131 100       282 $self->_checkType($key, $value, $type, 1, \$s)
278             or return undef ;
279             #$value = $$value unless $type & Parse_store_ref ;
280 127         205 $value = $$value ;
281 127         502 $got->{$canonkey} = [1, $type, $value, $s] ;
282             }
283             else
284 3         9 { push (@Bad, $key) }
285             }
286              
287 89 100       216 if (@Bad) {
288 3         11 my ($bad) = join(", ", @Bad) ;
289 3         14 return $self->setError("unknown key value(s) @Bad") ;
290             }
291              
292 86         229 return 1;
293             }
294              
295             sub Compress::Raw::Zlib::Parameters::_checkType
296             {
297 911     911   1267 my $self = shift ;
298              
299 911         1194 my $key = shift ;
300 911         1177 my $value = shift ;
301 911         1151 my $type = shift ;
302 911         1192 my $validate = shift ;
303 911         1165 my $output = shift;
304              
305             #local $Carp::CarpLevel = $level ;
306             #print "PARSE $type $key $value $validate $sub\n" ;
307             # if ( $type & Parse_store_ref)
308             # {
309             # #$value = $$value
310             # # if ref ${ $value } ;
311             #
312             # $$output = $value ;
313             # return 1;
314             # }
315              
316 911         1247 $value = $$value ;
317              
318 911 100       2176 if ($type & Parse_any)
    100          
    100          
    50          
319             {
320 90         149 $$output = $value ;
321 90         202 return 1;
322             }
323             elsif ($type & Parse_unsigned)
324             {
325 246 50 66     540 return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
326             if $validate && ! defined $value ;
327 246 100 100     590 return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
328             if $validate && $value !~ /^\d+$/;
329              
330 242 100       432 $$output = defined $value ? $value : 0 ;
331 242         538 return 1;
332             }
333             elsif ($type & Parse_signed)
334             {
335 150 50 66     429 return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
336             if $validate && ! defined $value ;
337 150 50 66     402 return $self->setError("Parameter '$key' must be a signed int, got '$value'")
338             if $validate && $value !~ /^-?\d+$/;
339              
340 150 100       278 $$output = defined $value ? $value : 0 ;
341 150         384 return 1 ;
342             }
343             elsif ($type & Parse_boolean)
344             {
345 425 50 66     1206 return $self->setError("Parameter '$key' must be an int, got '$value'")
      66        
346             if $validate && defined $value && $value !~ /^\d*$/;
347 425 50       775 $$output = defined $value ? $value != 0 : 0 ;
348 425         1010 return 1;
349             }
350             # elsif ($type & Parse_string)
351             # {
352             # $$output = defined $value ? $value : "" ;
353             # return 1;
354             # }
355              
356 0         0 $$output = $value ;
357 0         0 return 1;
358             }
359              
360              
361              
362             sub Compress::Raw::Zlib::Parameters::parsed
363             {
364 35     35   53 my $self = shift ;
365 35         48 my $name = shift ;
366              
367 35         329 return $self->{Got}{lc $name}[OFF_PARSED] ;
368             }
369              
370             sub Compress::Raw::Zlib::Parameters::value
371             {
372 784     784   1052 my $self = shift ;
373 784         1036 my $name = shift ;
374              
375 784 50       1318 if (@_)
376             {
377 0         0 $self->{Got}{lc $name}[OFF_PARSED] = 1;
378 0         0 $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
379 0         0 $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ;
380             }
381              
382 784         20260 return $self->{Got}{lc $name}[OFF_FIXED] ;
383             }
384              
385             our $OPTIONS_deflate =
386             {
387             'AppendOutput' => [1, 1, Parse_boolean, 0],
388             'CRC32' => [1, 1, Parse_boolean, 0],
389             'ADLER32' => [1, 1, Parse_boolean, 0],
390             'Bufsize' => [1, 1, Parse_unsigned, 4096],
391              
392             'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()],
393             'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()],
394             'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
395             'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()],
396             'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()],
397             'Dictionary' => [1, 1, Parse_any, ""],
398             };
399              
400             sub Compress::Raw::Zlib::Deflate::new
401             {
402 39     39   78294 my $pkg = shift ;
403 39         117 my ($got) = ParseParameters(0, $OPTIONS_deflate, @_);
404              
405 34 100       92 croak "Compress::Raw::Zlib::Deflate::new: Bufsize must be >= 1, you specified " .
406             $got->value('Bufsize')
407             unless $got->value('Bufsize') >= 1;
408              
409 33         179 my $flags = 0 ;
410 33 100       97 $flags |= FLAG_APPEND if $got->value('AppendOutput') ;
411 33 50       83 $flags |= FLAG_CRC if $got->value('CRC32') ;
412 33 50       89 $flags |= FLAG_ADLER if $got->value('ADLER32') ;
413              
414 33         93 my $windowBits = $got->value('WindowBits');
415 33 100       97 $windowBits += MAX_WBITS()
416             if ($windowBits & MAX_WBITS()) == 0 ;
417              
418 33         74 _deflateInit($flags,
419             $got->value('Level'),
420             $got->value('Method'),
421             $windowBits,
422             $got->value('MemLevel'),
423             $got->value('Strategy'),
424             $got->value('Bufsize'),
425             $got->value('Dictionary')) ;
426              
427             }
428              
429             sub Compress::Raw::Zlib::deflateStream::STORABLE_freeze
430             {
431 0     0   0 my $type = ref shift;
432 0         0 croak "Cannot freeze $type object\n";
433             }
434              
435             sub Compress::Raw::Zlib::deflateStream::STORABLE_thaw
436             {
437 0     0   0 my $type = ref shift;
438 0         0 croak "Cannot thaw $type object\n";
439             }
440              
441              
442             our $OPTIONS_inflate =
443             {
444             'AppendOutput' => [1, 1, Parse_boolean, 0],
445             'LimitOutput' => [1, 1, Parse_boolean, 0],
446             'CRC32' => [1, 1, Parse_boolean, 0],
447             'ADLER32' => [1, 1, Parse_boolean, 0],
448             'ConsumeInput' => [1, 1, Parse_boolean, 1],
449             'Bufsize' => [1, 1, Parse_unsigned, 4096],
450              
451             'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
452             'Dictionary' => [1, 1, Parse_any, ""],
453             } ;
454              
455             sub Compress::Raw::Zlib::Inflate::new
456             {
457 50     50   4449 my $pkg = shift ;
458 50         142 my ($got) = ParseParameters(0, $OPTIONS_inflate, @_);
459              
460 45 100       113 croak "Compress::Raw::Zlib::Inflate::new: Bufsize must be >= 1, you specified " .
461             $got->value('Bufsize')
462             unless $got->value('Bufsize') >= 1;
463              
464 44         74 my $flags = 0 ;
465 44 100       105 $flags |= FLAG_APPEND if $got->value('AppendOutput') ;
466 44 50       128 $flags |= FLAG_CRC if $got->value('CRC32') ;
467 44 50       111 $flags |= FLAG_ADLER if $got->value('ADLER32') ;
468 44 100       96 $flags |= FLAG_CONSUME_INPUT if $got->value('ConsumeInput') ;
469 44 100       97 $flags |= FLAG_LIMIT_OUTPUT if $got->value('LimitOutput') ;
470              
471              
472 44         94 my $windowBits = $got->value('WindowBits');
473 44 100       122 $windowBits += MAX_WBITS()
474             if ($windowBits & MAX_WBITS()) == 0 ;
475              
476 44         100 _inflateInit($flags, $windowBits, $got->value('Bufsize'),
477             $got->value('Dictionary')) ;
478             }
479              
480             sub Compress::Raw::Zlib::inflateStream::STORABLE_freeze
481             {
482 0     0   0 my $type = ref shift;
483 0         0 croak "Cannot freeze $type object\n";
484             }
485              
486             sub Compress::Raw::Zlib::inflateStream::STORABLE_thaw
487             {
488 0     0   0 my $type = ref shift;
489 0         0 croak "Cannot thaw $type object\n";
490             }
491              
492             sub Compress::Raw::Zlib::InflateScan::new
493             {
494 1     1   276 my $pkg = shift ;
495 1         10 my ($got) = ParseParameters(0,
496             {
497             'CRC32' => [1, 1, Parse_boolean, 0],
498             'ADLER32' => [1, 1, Parse_boolean, 0],
499             'Bufsize' => [1, 1, Parse_unsigned, 4096],
500              
501             'WindowBits' => [1, 1, Parse_signed, -MAX_WBITS()],
502             'Dictionary' => [1, 1, Parse_any, ""],
503             }, @_) ;
504              
505              
506 1 50       50 croak "Compress::Raw::Zlib::InflateScan::new: Bufsize must be >= 1, you specified " .
507             $got->value('Bufsize')
508             unless $got->value('Bufsize') >= 1;
509              
510 1         3 my $flags = 0 ;
511             #$flags |= FLAG_APPEND if $got->value('AppendOutput') ;
512 1 50       4 $flags |= FLAG_CRC if $got->value('CRC32') ;
513 1 50       5 $flags |= FLAG_ADLER if $got->value('ADLER32') ;
514             #$flags |= FLAG_CONSUME_INPUT if $got->value('ConsumeInput') ;
515              
516 1         7 _inflateScanInit($flags, $got->value('WindowBits'), $got->value('Bufsize'),
517             '') ;
518             }
519              
520             sub Compress::Raw::Zlib::inflateScanStream::createDeflateStream
521             {
522 0     0   0 my $pkg = shift ;
523 0         0 my ($got) = ParseParameters(0,
524             {
525             'AppendOutput' => [1, 1, Parse_boolean, 0],
526             'CRC32' => [1, 1, Parse_boolean, 0],
527             'ADLER32' => [1, 1, Parse_boolean, 0],
528             'Bufsize' => [1, 1, Parse_unsigned, 4096],
529              
530             'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()],
531             'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()],
532             'WindowBits' => [1, 1, Parse_signed, - MAX_WBITS()],
533             'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()],
534             'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()],
535             }, @_) ;
536              
537 0 0       0 croak "Compress::Raw::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified " .
538             $got->value('Bufsize')
539             unless $got->value('Bufsize') >= 1;
540              
541 0         0 my $flags = 0 ;
542 0 0       0 $flags |= FLAG_APPEND if $got->value('AppendOutput') ;
543 0 0       0 $flags |= FLAG_CRC if $got->value('CRC32') ;
544 0 0       0 $flags |= FLAG_ADLER if $got->value('ADLER32') ;
545              
546 0         0 $pkg->_createDeflateStream($flags,
547             $got->value('Level'),
548             $got->value('Method'),
549             $got->value('WindowBits'),
550             $got->value('MemLevel'),
551             $got->value('Strategy'),
552             $got->value('Bufsize'),
553             ) ;
554              
555             }
556              
557             sub Compress::Raw::Zlib::inflateScanStream::inflate
558             {
559 0     0   0 my $self = shift ;
560 0         0 my $buffer = $_[1];
561 0         0 my $eof = $_[2];
562              
563 0         0 my $status = $self->scan(@_);
564              
565 0 0 0     0 if ($status == Z_OK() && $_[2]) {
566 0         0 my $byte = ' ';
567              
568 0         0 $status = $self->scan(\$byte, $_[1]) ;
569             }
570              
571 0         0 return $status ;
572             }
573              
574             sub Compress::Raw::Zlib::deflateStream::deflateParams
575             {
576 7     7   716 my $self = shift ;
577 7         43 my ($got) = ParseParameters(0, {
578             'Level' => [1, 1, Parse_signed, undef],
579             'Strategy' => [1, 1, Parse_unsigned, undef],
580             'Bufsize' => [1, 1, Parse_unsigned, undef],
581             },
582             @_) ;
583              
584 6 100       25 croak "Compress::Raw::Zlib::deflateParams needs Level and/or Strategy"
585             unless $got->parsed('Level') + $got->parsed('Strategy') +
586             $got->parsed('Bufsize');
587              
588 5 100 100     11 croak "Compress::Raw::Zlib::Inflate::deflateParams: Bufsize must be >= 1, you specified " .
589             $got->value('Bufsize')
590             if $got->parsed('Bufsize') && $got->value('Bufsize') <= 1;
591              
592 4         14 my $flags = 0;
593 4 100       8 $flags |= 1 if $got->parsed('Level') ;
594 4 100       9 $flags |= 2 if $got->parsed('Strategy') ;
595 4 100       10 $flags |= 4 if $got->parsed('Bufsize') ;
596              
597 4         11 $self->_deflateParams($flags, $got->value('Level'),
598             $got->value('Strategy'), $got->value('Bufsize'));
599              
600             }
601              
602              
603             1;
604             __END__