File Coverage

blib/lib/Compress/Raw/Zlib.pm
Criterion Covered Total %
statement 197 222 88.7
branch 68 102 66.7
condition 25 41 61.0
subroutine 36 38 94.7
pod 0 1 0.0
total 326 404 80.7


line stmt bran cond sub pod time code
1              
2             package Compress::Raw::Zlib;
3              
4             require 5.004 ;
5             require Exporter;
6 4     4   55 use AutoLoader;
  4         39  
  4         70  
7 4     4   68 use Carp ;
  4         86  
  4         75  
8              
9             #use Parse::Parameters;
10              
11 4     4   62 use strict ;
  4         37  
  4         67  
12 4     4   154 use warnings ;
  4         39  
  4         58  
13 4     4   675 use bytes ;
  4         37  
  4         54  
14             our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD);
15              
16             $VERSION = '2.004';
17             $XS_VERSION = $VERSION;
18             $VERSION = eval $VERSION;
19              
20             @ISA = qw(Exporter);
21             # Items to export into callers namespace by default. Note: do not export
22             # names by default without a very good reason. Use EXPORT_OK instead.
23             # Do not simply export all your public functions/methods/constants.
24             @EXPORT = qw(
25             adler32 crc32
26            
27             ZLIB_VERSION
28             ZLIB_VERNUM
29            
30             DEF_WBITS
31             OS_CODE
32            
33             MAX_MEM_LEVEL
34             MAX_WBITS
35            
36             Z_ASCII
37             Z_BEST_COMPRESSION
38             Z_BEST_SPEED
39             Z_BINARY
40             Z_BLOCK
41             Z_BUF_ERROR
42             Z_DATA_ERROR
43             Z_DEFAULT_COMPRESSION
44             Z_DEFAULT_STRATEGY
45             Z_DEFLATED
46             Z_ERRNO
47             Z_FILTERED
48             Z_FIXED
49             Z_FINISH
50             Z_FULL_FLUSH
51             Z_HUFFMAN_ONLY
52             Z_MEM_ERROR
53             Z_NEED_DICT
54             Z_NO_COMPRESSION
55             Z_NO_FLUSH
56             Z_NULL
57             Z_OK
58             Z_PARTIAL_FLUSH
59             Z_RLE
60             Z_STREAM_END
61             Z_STREAM_ERROR
62             Z_SYNC_FLUSH
63             Z_UNKNOWN
64             Z_VERSION_ERROR
65             );
66              
67              
68             sub AUTOLOAD {
69 32     32   378     my($constname);
70 32         1885     ($constname = $AUTOLOAD) =~ s/.*:://;
71 32         461     my ($error, $val) = constant($constname);
72 32 50       322     Carp::croak $error if $error;
73 4     4   87     no strict 'refs';
  4         38  
  4         61  
74 32     155325   622     *{$AUTOLOAD} = sub { $val };
  32         447  
  155325         4464908  
75 32         294     goto &{$AUTOLOAD};
  32         569  
76             }
77              
78 4     4   65 use constant FLAG_APPEND => 1 ;
  4         38  
  4         65  
79 4     4   59 use constant FLAG_CRC => 2 ;
  4         113  
  4         70  
80 4     4   60 use constant FLAG_ADLER => 4 ;
  4         37  
  4         71  
81 4     4   58 use constant FLAG_CONSUME_INPUT => 8 ;
  4         35  
  4         47  
82              
83             eval {
84                 require XSLoader;
85                 XSLoader::load('Compress::Raw::Zlib', $XS_VERSION);
86                 1;
87             } 
88             or do {
89                 require DynaLoader;
90                 local @ISA = qw(DynaLoader);
91                 bootstrap Compress::Raw::Zlib $XS_VERSION ;
92             };
93              
94              
95 4     4   105 use constant Parse_any => 0x01;
  4         106  
  4         61  
96 4     4   62 use constant Parse_unsigned => 0x02;
  4         36  
  4         49  
97 4     4   57 use constant Parse_signed => 0x04;
  4         37  
  4         49  
98 4     4   94 use constant Parse_boolean => 0x08;
  4         37  
  4         48  
99 4     4   59 use constant Parse_string => 0x10;
  4         38  
  4         51  
100 4     4   59 use constant Parse_custom => 0x12;
  4         71  
  4         50  
101              
102 4     4   57 use constant Parse_store_ref => 0x100 ;
  4         36  
  4         48  
103              
104 4     4   87 use constant OFF_PARSED => 0 ;
  4         35  
  4         51  
105 4     4   61 use constant OFF_TYPE => 1 ;
  4         35  
  4         48  
106 4     4   57 use constant OFF_DEFAULT => 2 ;
  4         36  
  4         48  
107 4     4   63 use constant OFF_FIXED => 3 ;
  4         59  
  4         50  
108 4     4   100 use constant OFF_FIRST_ONLY => 4 ;
  4         37  
  4         50  
109 4     4   63 use constant OFF_STICKY => 5 ;
  4         37  
  4         49  
110              
111              
112              
113             sub ParseParameters
114             {
115 85   50 85 0 1249     my $level = shift || 0 ;
116              
117 85         1886     my $sub = (caller($level + 1))[3] ;
118             #local $Carp::CarpLevel = 1 ;
119 85         1296     my $p = new Compress::Raw::Zlib::Parameters() ;
120 85 100       1189     $p->parse(@_)
121                     or croak "$sub: $p->{Error}" ;
122              
123 74         837     return $p;
124             }
125              
126              
127             sub Compress::Raw::Zlib::Parameters::new
128             {
129 85     85   762     my $class = shift ;
130              
131 85         1564     my $obj = { Error => '',
132                             Got => {},
133                           } ;
134              
135             #return bless $obj, ref($class) || $class || __PACKAGE__ ;
136 85         3314     return bless $obj, 'Compress::Raw::Zlib::Parameters' ;
137             }
138              
139             sub Compress::Raw::Zlib::Parameters::setError
140             {
141 11     11   97     my $self = shift ;
142 11         99     my $error = shift ;
143 11 50       106     my $retval = @_ ? shift : undef ;
144              
145 11         110     $self->{Error} = $error ;
146 11         228     return $retval;
147             }
148                       
149             #sub getError
150             #{
151             # my $self = shift ;
152             # return $self->{Error} ;
153             #}
154                       
155             sub Compress::Raw::Zlib::Parameters::parse
156             {
157 85     85   740     my $self = shift ;
158              
159 85         719     my $default = shift ;
160              
161 85         831     my $got = $self->{Got} ;
162 85         1033     my $firstTime = keys %{ $got } == 0 ;
  85         962  
163              
164 85         896     my (@Bad) ;
165 85         2829     my @entered = () ;
166              
167             # Allow the options to be passed as a hash reference or
168             # as the complete hash.
169 85 100       1008     if (@_ == 0) {
    100          
170 6         53         @entered = () ;
171                 }
172                 elsif (@_ == 1) {
173 8         271         my $href = $_[0] ;
174 8 100 66     173         return $self->setError("Expected even number of parameters, got 1")
      66        
175                         if ! defined $href or ! ref $href or ref $href ne "HASH" ;
176              
177 6         74         foreach my $key (keys %$href) {
178 12         111             push @entered, $key ;
179 12         126             push @entered, \$href->{$key} ;
180                     }
181                 }
182                 else {
183 71         635         my $count = @_;
184 71 100       939         return $self->setError("Expected even number of parameters, got $count")
185                         if $count % 2 != 0 ;
186                     
187 69         831         for my $i (0.. $count / 2 - 1) {
188 82         46852             push @entered, $_[2* $i] ;
189 82         1469             push @entered, \$_[2* $i+1] ;
190                     }
191                 }
192              
193              
194 81         1150     while (my ($key, $v) = each %$default)
195                 {
196 646 50       9745         croak "need 4 params [@$v]"
197                         if @$v != 4 ;
198              
199 646         6262         my ($first_only, $sticky, $type, $value) = @$v ;
200 646         5611         my $x ;
201 646 50       10629         $self->_checkType($key, \$value, $type, 0, \$x)
202                         or return undef ;
203              
204 646         8659         $key = lc $key;
205              
206 646 50 33     7685         if ($firstTime || ! $sticky) {
207 646         11413             $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
208                     }
209              
210 646         9910         $got->{$key}[OFF_PARSED] = 0 ;
211                 }
212              
213 81         1129     for my $i (0.. @entered / 2 - 1) {
214 94         1022         my $key = $entered[2* $i] ;
215 94         893         my $value = $entered[2* $i+1] ;
216              
217             #print "Key [$key] Value [$value]" ;
218             #print defined $$value ? "[$$value]\n" : "[undef]\n";
219              
220 94         1186         $key =~ s/^-// ;
221 94         876         my $canonkey = lc $key;
222              
223 94 100 33     1474         if ($got->{$canonkey} && ($firstTime ||
      66        
224                                               ! $got->{$canonkey}[OFF_FIRST_ONLY] ))
225                     {
226 91         1499             my $type = $got->{$canonkey}[OFF_TYPE] ;
227 91         891             my $s ;
228 91 100       1055             $self->_checkType($key, $value, $type, 1, \$s)
229                             or return undef ;
230             #$value = $$value unless $type & Parse_store_ref ;
231 87         775             $value = $$value ;
232 87         2639             $got->{$canonkey} = [1, $type, $value, $s] ;
233                     }
234                     else
235 3         37           { push (@Bad, $key) }
236                 }
237              
238 77 100       821     if (@Bad) {
239 3         33         my ($bad) = join(", ", @Bad) ;
240 3         42         return $self->setError("unknown key value(s) @Bad") ;
241                 }
242              
243 74         970     return 1;
244             }
245              
246             sub Compress::Raw::Zlib::Parameters::_checkType
247             {
248 737     737   8262     my $self = shift ;
249              
250 737         7399     my $key = shift ;
251 737         9257     my $value = shift ;
252 737         8967     my $type = shift ;
253 737         8728     my $validate = shift ;
254 737         6732     my $output = shift;
255              
256             #local $Carp::CarpLevel = $level ;
257             #print "PARSE $type $key $value $validate $sub\n" ;
258 737 50       7669     if ( $type & Parse_store_ref)
259                 {
260             #$value = $$value
261             # if ref ${ $value } ;
262              
263 0         0         $$output = $value ;
264 0         0         return 1;
265                 }
266              
267 737         7084     $value = $$value ;
268              
269 737 100       10960     if ($type & Parse_any)
    100          
    100          
    50          
    0          
270                 {
271 77         796         $$output = $value ;
272 77         1123         return 1;
273                 }
274                 elsif ($type & Parse_unsigned)
275                 {
276 217 50 66     2303         return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
277                         if $validate && ! defined $value ;
278 217 100 100     2654         return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
279                         if $validate && $value !~ /^\d+$/;
280              
281 213 100       3347         $$output = defined $value ? $value : 0 ;
282 213         2519         return 1;
283                 }
284                 elsif ($type & Parse_signed)
285                 {
286 124 50 66     1296         return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
287                         if $validate && ! defined $value ;
288 124 50 66     1416         return $self->setError("Parameter '$key' must be a signed int, got '$value'")
289                         if $validate && $value !~ /^-?\d+$/;
290              
291 124 100       1724         $$output = defined $value ? $value : 0 ;
292 124         1518         return 1 ;
293                 }
294                 elsif ($type & Parse_boolean)
295                 {
296 319 50 66     5002         return $self->setError("Parameter '$key' must be an int, got '$value'")
      66        
297                         if $validate && defined $value && $value !~ /^\d*$/;
298 319 50       3312         $$output = defined $value ? $value != 0 : 0 ;
299 319         3477         return 1;
300                 }
301                 elsif ($type & Parse_string)
302                 {
303 0 0       0         $$output = defined $value ? $value : "" ;
304 0         0         return 1;
305                 }
306              
307 0         0     $$output = $value ;
308 0         0     return 1;
309             }
310              
311              
312