File Coverage

blib/lib/IO/Compress/Base.pm
Criterion Covered Total %
statement 371 392 94.6
branch 181 234 77.3
condition 64 80 80.0
subroutine 51 54 94.4
pod 6 31 19.3
total 673 791 85.0


line stmt bran cond sub pod time code
1              
2             package IO::Compress::Base ;
3              
4             require 5.006 ;
5              
6 115     115   4483 use strict ;
  115         296  
  115         4504  
7 115     115   684 use warnings;
  115         217  
  115         6650  
8              
9 115     115   28818 use IO::Compress::Base::Common 2.219 ;
  115         2689  
  115         21104  
10              
11 115     115   53630 use IO::File ();
  115         834414  
  115         3766  
12 115     115   937 use Scalar::Util ();
  115         237  
  115         3371  
13              
14             #use File::Glob;
15             #require Exporter ;
16 115     115   607 use Carp() ;
  115         238  
  115         2308  
17 115     115   492 use Symbol();
  115         222  
  115         186370  
18             #use bytes;
19              
20             our (@ISA, $VERSION);
21             @ISA = qw(IO::File Exporter);
22              
23             $VERSION = '2.219';
24              
25             #Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16.
26              
27             sub saveStatus
28             {
29 1850     1850 0 3499 my $self = shift ;
30 1850         4417 ${ *$self->{ErrorNo} } = shift() + 0 ;
  1850         7563  
31 1850         3630 ${ *$self->{Error} } = '' ;
  1850         4900  
32              
33 1850         3233 return ${ *$self->{ErrorNo} } ;
  1850         5163  
34             }
35              
36              
37             sub saveErrorString
38             {
39 196     196 0 1031 my $self = shift ;
40 196         390 my $retval = shift ;
41 196         300 ${ *$self->{Error} } = shift ;
  196         584  
42 196 100       536 ${ *$self->{ErrorNo} } = shift() + 0 if @_ ;
  32         78  
43              
44 196         876 return $retval;
45             }
46              
47             sub croakError
48             {
49 149     149 0 290 my $self = shift ;
50 149         670 $self->saveErrorString(0, $_[0]);
51 149         37657 Carp::croak $_[0];
52             }
53              
54             sub closeError
55             {
56 0     0 0 0 my $self = shift ;
57 0         0 my $retval = shift ;
58              
59 0         0 my $errno = *$self->{ErrorNo};
60 0         0 my $error = ${ *$self->{Error} };
  0         0  
61              
62 0         0 $self->close();
63              
64 0         0 *$self->{ErrorNo} = $errno ;
65 0         0 ${ *$self->{Error} } = $error ;
  0         0  
66              
67 0         0 return $retval;
68             }
69              
70              
71              
72             sub error
73             {
74 42     42 1 200 my $self = shift ;
75 42         63 return ${ *$self->{Error} } ;
  42         222  
76             }
77              
78             sub errorNo
79             {
80 81     81 0 156 my $self = shift ;
81 81         132 return ${ *$self->{ErrorNo} } ;
  81         549  
82             }
83              
84              
85             sub writeAt
86             {
87 130     130 0 262 my $self = shift ;
88 130         214 my $offset = shift;
89 130         216 my $data = shift;
90              
91 130 100       352 if (defined *$self->{FH}) {
92 124         284 my $here = tell(*$self->{FH});
93 124 50       1527 return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!)
94             if $here < 0 ;
95 124 50       3410 seek(*$self->{FH}, $offset, IO::Handle::SEEK_SET)
96             or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
97 124 50       622 defined *$self->{FH}->write($data, length $data)
98             or return $self->saveErrorString(undef, $!, $!) ;
99 124 50       5337 seek(*$self->{FH}, $here, IO::Handle::SEEK_SET)
100             or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
101             }
102             else {
103 6         5 substr(${ *$self->{Buffer} }, $offset, length($data)) = $data ;
  6         11  
104             }
105              
106 130         542 return 1;
107             }
108              
109             sub outputPayload
110             {
111              
112 1552     1552 0 2743 my $self = shift ;
113 1552         4647 return $self->output(@_);
114             }
115              
116              
117             sub output
118             {
119 9579     9579 0 16062 my $self = shift ;
120 9579         18607 my $data = shift ;
121 9579         14663 my $last = shift ;
122              
123 9579 100 100     44122 return 1
124             if length $data == 0 && ! $last ;
125              
126 5268 50       16464 if ( *$self->{FilterContainer} ) {
127 0         0 *_ = \$data;
128 0         0 &{ *$self->{FilterContainer} }();
  0         0  
129             }
130              
131 5268 100       11355 if (length $data) {
132 3433 100       8529 if ( defined *$self->{FH} ) {
133 2039 50       10382 defined *$self->{FH}->write( $data, length $data )
134             or return $self->saveErrorString(0, $!, $!);
135             }
136             else {
137 1394         2134 ${ *$self->{Buffer} } .= $data ;
  1394         5331  
138             }
139             }
140              
141 5268         65215 return 1;
142             }
143              
144             sub getOneShotParams
145             {
146 695     695 0 10340 return ( 'multistream' => [IO::Compress::Base::Common::Parse_boolean, 1],
147             );
148             }
149              
150             our %PARAMS = (
151             # Generic Parameters
152             'autoclose' => [IO::Compress::Base::Common::Parse_boolean, 0],
153             'encode' => [IO::Compress::Base::Common::Parse_any, undef],
154             'strict' => [IO::Compress::Base::Common::Parse_boolean, 1],
155             'append' => [IO::Compress::Base::Common::Parse_boolean, 0],
156             'binmodein' => [IO::Compress::Base::Common::Parse_boolean, 0],
157              
158             'filtercontainer' => [IO::Compress::Base::Common::Parse_code, undef],
159             );
160              
161             sub checkParams
162             {
163 2071     2071 0 3977 my $self = shift ;
164 2071         3878 my $class = shift ;
165              
166 2071   66     9528 my $got = shift || IO::Compress::Base::Parameters::new();
167              
168             $got->parse(
169             {
170             %PARAMS,
171              
172              
173             $self->getExtraParams(),
174 2071 100       14911 *$self->{OneShot} ? $self->getOneShotParams()
    100          
175             : (),
176             },
177             @_) or $self->croakError("${class}: " . $got->getError()) ;
178              
179 2046         18142 return $got ;
180             }
181              
182             sub _create
183             {
184 1922     1922   3923 my $obj = shift;
185 1922         3730 my $got = shift;
186              
187 1922         5145 *$obj->{Closed} = 1 ;
188              
189 1922         4524 my $class = ref $obj;
190 1922 50 66     5973 $obj->croakError("$class: Missing Output parameter")
191             if ! @_ && ! $got ;
192              
193 1917         3643 my $outValue = shift ;
194 1917         3573 my $oneShot = 1 ;
195              
196 1917 100       9127 if (! $got)
197             {
198 1202         1916 $oneShot = 0 ;
199 1202 50       4852 $got = $obj->checkParams($class, undef, @_)
200             or return undef ;
201             }
202              
203 1897         8129 my $lax = ! $got->getValue('strict') ;
204              
205 1897         6311 my $outType = IO::Compress::Base::Common::whatIsOutput($outValue);
206              
207 1897 50       9184 $obj->ckOutputParam($class, $outValue)
208             or return undef ;
209              
210 1887 100       5499 if ($outType eq 'buffer') {
211 790         2687 *$obj->{Buffer} = $outValue;
212             }
213             else {
214 1097         2352 my $buff = "" ;
215 1097         5289 *$obj->{Buffer} = \$buff ;
216             }
217              
218             # Merge implies Append
219 1887         5884 my $merge = $got->getValue('merge') ;
220 1887   100     5084 my $appendOutput = $got->getValue('append') || $merge ;
221 1887         5261 *$obj->{Append} = $appendOutput;
222 1887         6062 *$obj->{FilterContainer} = $got->getValue('filtercontainer') ;
223              
224 1887 100       5041 if ($merge)
225             {
226             # Switch off Merge mode if output file/buffer is empty/doesn't exist
227 81 100 100     1767 if (($outType eq 'buffer' && length $$outValue == 0 ) ||
      100        
      100        
      100        
228             ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) )
229 12         23 { $merge = 0 }
230             }
231              
232             # If output is a file, check that it is writable
233             #no warnings;
234             #if ($outType eq 'filename' && -e $outValue && ! -w _)
235             # { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) }
236              
237 1887 100       8329 $obj->ckParams($got)
238             or $obj->croakError("${class}: " . $obj->error());
239              
240 1855 100       6743 if ($got->getValue('encode')) {
241 20         49 my $want_encoding = $got->getValue('encode');
242 20         75 *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding);
243 15         48 my $x = *$obj->{Encoding};
244             }
245             else {
246 1835         7394 *$obj->{Encoding} = undef;
247             }
248              
249 1850         8850 $obj->saveStatus(STATUS_OK) ;
250              
251 1850         3133 my $status ;
252 1850 100       4861 if (! $merge)
253             {
254 1781 50       7193 *$obj->{Compress} = $obj->mkComp($got)
255             or return undef;
256              
257 1781         11112 *$obj->{UnCompSize} = U64->new;
258 1781         5231 *$obj->{CompSize} = U64->new;
259              
260 1781 100       6010 if ( $outType eq 'buffer') {
261 727 100       2500 ${ *$obj->{Buffer} } = ''
  589         2044  
262             unless $appendOutput ;
263             }
264             else {
265 1054 100       4602 if ($outType eq 'handle') {
    50          
266 214         1316 *$obj->{FH} = $outValue ;
267 214         1165 setBinModeOutput(*$obj->{FH}) ;
268             #$outValue->flush() ;
269 214         785 *$obj->{Handle} = 1 ;
270 214 100       775 if ($appendOutput)
271             {
272 53 50       645 seek(*$obj->{FH}, 0, IO::Handle::SEEK_END)
273             or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
274              
275             }
276             }
277             elsif ($outType eq 'filename') {
278 115     115   1052 no warnings;
  115         242  
  115         431953  
279 840         5628 my $mode = '>' ;
280 840 100       2244 $mode = '>>'
281             if $appendOutput;
282 840 100       8271 *$obj->{FH} = IO::File->new( "$mode $outValue" )
283             or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ;
284 835         178405 *$obj->{StdIO} = ($outValue eq '-');
285 835         4439 setBinModeOutput(*$obj->{FH}) ;
286             }
287             }
288              
289 1776         9453 *$obj->{Header} = $obj->mkHeader($got) ;
290             $obj->output( *$obj->{Header} )
291 1775 50       8565 or return undef;
292 1775         7108 $obj->beforePayload();
293             }
294             else
295             {
296 69 100       323 *$obj->{Compress} = $obj->createMerge($outValue, $outType)
297             or return undef;
298             }
299              
300 1835         5592 *$obj->{Closed} = 0 ;
301 1835         9633 *$obj->{AutoClose} = $got->getValue('autoclose') ;
302 1835         6014 *$obj->{Output} = $outValue;
303 1835         4835 *$obj->{ClassName} = $class;
304 1835         4493 *$obj->{Got} = $got;
305 1835         4126 *$obj->{OneShot} = 0 ;
306              
307 1835         9098 return $obj ;
308             }
309              
310             sub ckOutputParam
311             {
312 1897     1897 0 3879 my $self = shift ;
313 1897         3690 my $from = shift ;
314 1897         4918 my $outType = IO::Compress::Base::Common::whatIsOutput($_[0]);
315              
316 1897 100       5113 $self->croakError("$from: output parameter not a filename, filehandle or scalar ref")
317             if ! $outType ;
318              
319             #$self->croakError("$from: output filename is undef or null string")
320             #if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ;
321              
322             $self->croakError("$from: output buffer is read-only")
323 1892 100 100     6679 if $outType eq 'buffer' && Scalar::Util::readonly(${ $_[0] });
  795         4570  
324              
325 1887         6131 return 1;
326             }
327              
328              
329             sub _def
330             {
331 830     830   1754 my $obj = shift ;
332              
333 830         3149 my $class= (caller)[0] ;
334 830         6367 my $name = (caller(1))[3] ;
335              
336 830 100       3885 $obj->croakError("$name: expected at least 1 parameters\n")
337             unless @_ >= 1 ;
338              
339 825         3319 my $input = shift ;
340 825         1661 my $haveOut = @_ ;
341 825         1646 my $output = shift ;
342              
343 825 100       7904 my $x = IO::Compress::Base::Validator->new($class, *$obj->{Error}, $name, $input, $output)
344             or return undef ;
345              
346 695 50 33     4189 push @_, $output if $haveOut && $x->{Hash};
347              
348 695         2334 *$obj->{OneShot} = 1 ;
349              
350 695 50       4061 my $got = $obj->checkParams($name, undef, @_)
351             or return undef ;
352              
353 690         2377 $x->{Got} = $got ;
354              
355             # if ($x->{Hash})
356             # {
357             # while (my($k, $v) = each %$input)
358             # {
359             # $v = \$input->{$k}
360             # unless defined $v ;
361             #
362             # $obj->_singleTarget($x, 1, $k, $v, @_)
363             # or return undef ;
364             # }
365             #
366             # return keys %$input ;
367             # }
368              
369 690 100       2638 if ($x->{GlobMap})
370             {
371 10         33 $x->{oneInput} = 1 ;
372 10         23 foreach my $pair (@{ $x->{Pairs} })
  10         37  
373             {
374 20         67 my ($from, $to) = @$pair ;
375 20 50       87 $obj->_singleTarget($x, 1, $from, $to, @_)
376             or return undef ;
377             }
378              
379 10         30 return scalar @{ $x->{Pairs} } ;
  10         146  
380             }
381              
382 680 100       2284 if (! $x->{oneOutput} )
383             {
384             my $inFile = ($x->{inType} eq 'filenames'
385 75   100     379 || $x->{inType} eq 'filename');
386              
387 75 100       16357 $x->{inType} = $inFile ? 'filename' : 'buffer';
388              
389 75 100       308 foreach my $in ($x->{oneInput} ? $input : @$input)
390             {
391 90         177 my $out ;
392 90         235 $x->{oneInput} = 1 ;
393              
394 90 50       402 $obj->_singleTarget($x, $inFile, $in, \$out, @_)
395             or return undef ;
396              
397 90         340 push @$output, \$out ;
398             #if ($x->{outType} eq 'array')
399             # { push @$output, \$out }
400             #else
401             # { $output->{$in} = \$out }
402             }
403              
404 75         681 return 1 ;
405             }
406              
407             # finally the 1 to 1 and n to 1
408 605         3025 return $obj->_singleTarget($x, 1, $input, $output, @_);
409              
410 0         0 Carp::croak "should not be here" ;
411             }
412              
413             sub _singleTarget
414             {
415 715     715   1501 my $obj = shift ;
416 715         1411 my $x = shift ;
417 715         1378 my $inputIsFilename = shift;
418 715         1553 my $input = shift;
419              
420 715 100       2706 if ($x->{oneInput})
421             {
422 640 100 66     3015 $obj->getFileInfo($x->{Got}, $input)
      100        
423             if isaScalar($input) || (isaFilename($input) and $inputIsFilename) ;
424              
425 640 100       2943 my $z = $obj->_create($x->{Got}, @_)
426             or return undef ;
427              
428              
429 635 50       2458 defined $z->_wr2($input, $inputIsFilename)
430             or return $z->closeError(undef) ;
431              
432 635         3304 return $z->close() ;
433             }
434             else
435             {
436 75         179 my $afterFirst = 0 ;
437 75         244 my $inputIsFilename = ($x->{inType} ne 'array');
438 75         427 my $keep = $x->{Got}->clone();
439              
440             #for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
441 75         227 for my $element ( @$input)
442             {
443 180         742 my $isFilename = isaFilename($element);
444              
445 180 100       533 if ( $afterFirst ++ )
446             {
447 105 50       373 defined addInterStream($obj, $element, $isFilename)
448             or return $obj->closeError(undef) ;
449             }
450             else
451             {
452 75 50 33     303 $obj->getFileInfo($x->{Got}, $element)
453             if isaScalar($element) || $isFilename;
454              
455 75 50       405 $obj->_create($x->{Got}, @_)
456             or return undef ;
457             }
458              
459 180 50       666 defined $obj->_wr2($element, $isFilename)
460             or return $obj->closeError(undef) ;
461              
462 180         749 *$obj->{Got} = $keep->clone();
463             }
464 75         400 return $obj->close() ;
465             }
466              
467             }
468              
469             sub _wr2
470             {
471 815     815   1553 my $self = shift ;
472              
473 815         4660 my $source = shift ;
474 815         1613 my $inputIsFilename = shift;
475              
476 815         1529 my $input = $source ;
477 815 100       2122 if (! $inputIsFilename)
478             {
479 30 50       117 $input = \$source
480             if ! ref $source;
481             }
482              
483 815 100 100     3788 if ( ref $input && ref $input eq 'SCALAR' )
484             {
485 248         1077 return $self->syswrite($input, @_) ;
486             }
487              
488 567 50 66     2322 if ( ! ref $input || isaFilehandle($input))
489             {
490 567         1807 my $isFilehandle = isaFilehandle($input) ;
491              
492 567         1354 my $fh = $input ;
493              
494 567 100       6480 if ( ! $isFilehandle )
495             {
496 410 50       9210 $fh = IO::File->new( "<$input" )
497             or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ;
498             }
499 567         43293 binmode $fh ;
500              
501 567         1459 my $status ;
502             my $buff ;
503 567         1197 my $count = 0 ;
504 567         16333 while ($status = read($fh, $buff, 16 * 1024)) {
505 407         1292 $count += length $buff;
506 407 50       2518 defined $self->syswrite($buff, @_)
507             or return undef ;
508             }
509              
510 567 50       1727 return $self->saveErrorString(undef, $!, $!)
511             if ! defined $status ;
512              
513 567 100 100     3539 if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-')
      66        
514             {
515 440 50       2074 $fh->close()
516             or return undef ;
517             }
518              
519 567         13043 return $count ;
520             }
521              
522 0         0 Carp::croak "Should not be here";
523 0         0 return undef;
524             }
525              
526             sub addInterStream
527             {
528 105     105 0 203 my $self = shift ;
529 105         205 my $input = shift ;
530 105         208 my $inputIsFilename = shift ;
531              
532 105 100       462 if (*$self->{Got}->getValue('multistream'))
    50          
533             {
534 60 50 33     195 $self->getFileInfo(*$self->{Got}, $input)
535             #if isaFilename($input) and $inputIsFilename ;
536             if isaScalar($input) || isaFilename($input) ;
537              
538             # TODO -- newStream needs to allow gzip/zip header to be modified
539 60         349 return $self->newStream();
540             }
541             elsif (*$self->{Got}->getValue('autoflush'))
542             {
543             #return $self->flush(Z_FULL_FLUSH);
544             }
545              
546 45         161 return 1 ;
547             }
548              
549             sub getFileInfo
550       0 0   {
551             }
552              
553             sub TIEHANDLE
554             {
555 2037 50   2037   11916 return $_[0] if ref($_[0]);
556 0         0 die "OOPS\n" ;
557             }
558              
559             sub UNTIE
560             {
561 1810     1810   6266 my $self = shift ;
562             }
563              
564             sub DESTROY
565             {
566 2036     2036   214358 my $self = shift ;
567 2036         18866 local ($., $@, $!, $^E, $?);
568              
569 2036         8307 $self->close() ;
570              
571             # TODO - memory leak with 5.8.0 - this isn't called until
572             # global destruction
573             #
574 2036         3748 %{ *$self } = () ;
  2036         122906  
575 2036         34837 undef $self ;
576             }
577              
578              
579              
580             sub filterUncompressed
581       1524 0   {
582             }
583              
584             sub syswrite
585             {
586 2142     2142 0 164315 my $self = shift ;
587              
588 2142         4215 my $buffer ;
589 2142 100       5837 if (ref $_[0] ) {
590 283 100       1079 $self->croakError( *$self->{ClassName} . "::write: not a scalar reference" )
591             unless ref $_[0] eq 'SCALAR' ;
592 248         508 $buffer = $_[0] ;
593             }
594             else {
595 1859         8785 $buffer = \$_[0] ;
596             }
597              
598 2107 100       7105 if (@_ > 1) {
599 85 50       230 my $slen = defined $$buffer ? length($$buffer) : 0;
600 85         142 my $len = $slen;
601 85         142 my $offset = 0;
602 85 100       238 $len = $_[1] if $_[1] < $len;
603              
604 85 100       217 if (@_ > 2) {
605 40   50     158 $offset = $_[2] || 0;
606 40 100       157 $self->croakError(*$self->{ClassName} . "::write: offset outside string")
607             if $offset > $slen;
608 35 100       108 if ($offset < 0) {
609 20         45 $offset += $slen;
610 20 100       114 $self->croakError( *$self->{ClassName} . "::write: offset outside string") if $offset < 0;
611             }
612 30         63 my $rem = $slen - $offset;
613 30 50       96 $len = $rem if $rem < $len;
614             }
615              
616 75         223 $buffer = \substr($$buffer, $offset, $len) ;
617             }
618              
619 2097 100 100     14951 return 0 if (! defined $$buffer || length $$buffer == 0) && ! *$self->{FlushPending};
      66        
620              
621             # *$self->{Pending} .= $$buffer ;
622             #
623             # return length $$buffer
624             # if (length *$self->{Pending} < 1024 * 16 && ! *$self->{FlushPending}) ;
625             #
626             # $$buffer = *$self->{Pending} ;
627             # *$self->{Pending} = '';
628              
629 1922 100       6446 if (*$self->{Encoding}) {
630 15         130 $$buffer = *$self->{Encoding}->encode($$buffer);
631             }
632             else {
633             $] >= 5.008 and ( utf8::downgrade($$buffer, 1)
634 1907 50 66     12377 or Carp::croak "Wide character in " . *$self->{ClassName} . "::write:");
635             }
636              
637 1917         7640 $self->filterUncompressed($buffer);
638              
639 1917 50       6023 my $buffer_length = defined $$buffer ? length($$buffer) : 0 ;
640 1917         12061 *$self->{UnCompSize}->add($buffer_length) ;
641              
642 1917         5706 my $outBuffer='';
643 1917         9233 my $status = *$self->{Compress}->compr($buffer, $outBuffer) ;
644              
645             return $self->saveErrorString(undef, *$self->{Compress}{Error},
646             *$self->{Compress}{ErrorNo})
647 1917 50       5432 if $status == STATUS_ERROR;
648              
649 1917         8043 *$self->{CompSize}->add(length $outBuffer) ;
650              
651 1917 50       6776 $self->outputPayload($outBuffer)
652             or return undef;
653              
654 1917         9796 return $buffer_length;
655             }
656              
657             sub print
658             {
659 316     316 0 6218 my $self = shift;
660              
661             #if (ref $self) {
662             # $self = *$self{GLOB} ;
663             #}
664              
665 316 100       1102 if (defined $\) {
666 30 100       97 if (defined $,) {
667 15         98 defined $self->syswrite(join($,, @_) . $\);
668             } else {
669 15         90 defined $self->syswrite(join("", @_) . $\);
670             }
671             } else {
672 286 100       822 if (defined $,) {
673 5         26 defined $self->syswrite(join($,, @_));
674             } else {
675 281         2564 defined $self->syswrite(join("", @_));
676             }
677             }
678             }
679              
680             sub printf
681             {
682 90     90 0 321 my $self = shift;
683 90         145 my $fmt = shift;
684 90         555 defined $self->syswrite(sprintf($fmt, @_));
685             }
686              
687             sub _flushCompressed
688             {
689 35     35   64 my $self = shift ;
690              
691 35         88 my $outBuffer='';
692 35         330 my $status = *$self->{Compress}->flush($outBuffer, @_) ;
693             return $self->saveErrorString(0, *$self->{Compress}{Error},
694             *$self->{Compress}{ErrorNo})
695 35 100       147 if $status == STATUS_ERROR;
696              
697 34 100       138 if ( defined *$self->{FH} ) {
698 25         181 *$self->{FH}->clearerr();
699             }
700              
701 34         199 *$self->{CompSize}->add(length $outBuffer) ;
702              
703 34 50       116 $self->outputPayload($outBuffer)
704             or return 0;
705 34         104 return 1;
706             }
707              
708             sub flush
709             {
710 35     35 1 324 my $self = shift ;
711              
712 35 100       187 $self->_flushCompressed(@_)
713             or return 0;
714              
715 34 100       154 if ( defined *$self->{FH} ) {
716             defined *$self->{FH}->flush()
717 25 50       1089 or return $self->saveErrorString(0, $!, $!);
718             }
719              
720 34         222 return 1;
721             }
722              
723             sub beforePayload
724       1538 0   {
725             }
726              
727             sub _newStream
728             {
729 174     174   317 my $self = shift ;
730 174         334 my $got = shift;
731              
732 174         388 my $class = ref $self;
733              
734 174 50       697 $self->_writeTrailer()
735             or return 0 ;
736              
737 174 50       658 $self->ckParams($got)
738             or $self->croakError("newStream: $self->{Error}");
739              
740 174 50       528 if ($got->getValue('encode')) {
741 0         0 my $want_encoding = $got->getValue('encode');
742 0         0 *$self->{Encoding} = IO::Compress::Base::Common::getEncoding($self, $class, $want_encoding);
743             }
744             else {
745 174         538 *$self->{Encoding} = undef;
746             }
747              
748 174 50       586 *$self->{Compress} = $self->mkComp($got)
749             or return 0;
750              
751 174         2105 *$self->{Header} = $self->mkHeader($got) ;
752             $self->output(*$self->{Header} )
753 174 50       715 or return 0;
754              
755 174         4336 *$self->{UnCompSize}->reset();
756 174         563 *$self->{CompSize}->reset();
757              
758 174         634 $self->beforePayload();
759              
760 174         876 return 1 ;
761             }
762              
763             sub newStream
764             {
765 174     174 0 541 my $self = shift ;
766              
767 174 50       792 my $got = $self->checkParams('newStream', *$self->{Got}, @_)
768             or return 0 ;
769              
770 174         803 $self->_newStream($got);
771              
772             # *$self->{Compress} = $self->mkComp($got)
773             # or return 0;
774             #
775             # *$self->{Header} = $self->mkHeader($got) ;
776             # $self->output(*$self->{Header} )
777             # or return 0;
778             #
779             # *$self->{UnCompSize}->reset();
780             # *$self->{CompSize}->reset();
781             #
782             # $self->beforePayload();
783             #
784             # return 1 ;
785             }
786              
787             sub reset
788             {
789 0     0 0 0 my $self = shift ;
790 0         0 return *$self->{Compress}->reset() ;
791             }
792              
793             sub _writeTrailer
794             {
795 2009     2009   3677 my $self = shift ;
796              
797 2009         4127 my $trailer = '';
798              
799 2009         9723 my $status = *$self->{Compress}->close($trailer) ;
800              
801             return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo})
802 2009 50       57181 if $status == STATUS_ERROR;
803              
804 2009         16651 *$self->{CompSize}->add(length $trailer) ;
805              
806 2009         8553 $trailer .= $self->mkTrailer();
807 2009 50       5921 defined $trailer
808             or return 0;
809 2009         6281 return $self->output($trailer);
810             }
811              
812             sub _writeFinalTrailer
813             {
814 1835     1835   3304 my $self = shift ;
815              
816 1835         6828 return $self->output($self->mkFinalTrailer());
817             }
818              
819             sub close
820             {
821 3804     3804 0 21946 my $self = shift ;
822 3804 100 66     23101 return 1 if *$self->{Closed} || ! *$self->{Compress} ;
823 1835         4754 *$self->{Closed} = 1 ;
824              
825 1835 50       11809 untie *$self
826             if $] >= 5.008 ;
827              
828 1835         4997 *$self->{FlushPending} = 1 ;
829 1835 50       6653 $self->_writeTrailer()
830             or return 0 ;
831              
832 1835 50       7164 $self->_writeFinalTrailer()
833             or return 0 ;
834              
835 1835 50       5211 $self->output( "", 1 )
836             or return 0;
837              
838 1835 100       5865 if (defined *$self->{FH}) {
839              
840 1084 100 100     7852 if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
      66        
841 1018         2744 $! = 0 ;
842             *$self->{FH}->close()
843 1018 50       5367 or return $self->saveErrorString(0, $!, $!);
844             }
845 1084         86695 delete *$self->{FH} ;
846             # This delete can set $! in older Perls, so reset the errno
847 1084         2885 $! = 0 ;
848             }
849              
850 1835         13642 return 1;
851             }
852              
853              
854             #sub total_in
855             #sub total_out
856             #sub msg
857             #
858             #sub crc
859             #{
860             # my $self = shift ;
861             # return *$self->{Compress}->crc32() ;
862             #}
863             #
864             #sub msg
865             #{
866             # my $self = shift ;
867             # return *$self->{Compress}->msg() ;
868             #}
869             #
870             #sub dict_adler
871             #{
872             # my $self = shift ;
873             # return *$self->{Compress}->dict_adler() ;
874             #}
875             #
876             #sub get_Level
877             #{
878             # my $self = shift ;
879             # return *$self->{Compress}->get_Level() ;
880             #}
881             #
882             #sub get_Strategy
883             #{
884             # my $self = shift ;
885             # return *$self->{Compress}->get_Strategy() ;
886             #}
887              
888              
889             sub tell
890             {
891 151     151 1 494 my $self = shift ;
892              
893 151         742 return *$self->{UnCompSize}->get32bit() ;
894             }
895              
896             sub eof
897             {
898 116     116 0 1440 my $self = shift ;
899              
900 116         471 return *$self->{Closed} ;
901             }
902              
903              
904             sub seek
905             {
906 65     65 1 4498 my $self = shift ;
907 65         126 my $position = shift;
908 65         127 my $whence = shift ;
909              
910 65         268 my $here = $self->tell() ;
911 65         127 my $target = 0 ;
912              
913             #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
914 115     115   1186 use IO::Handle ;
  115         267  
  115         56168  
915              
916 65 100 100     404 if ($whence == IO::Handle::SEEK_SET) {
    100          
917 11         24 $target = $position ;
918             }
919             elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) {
920 43         109 $target = $here + $position ;
921             }
922             else {
923 11         143 $self->croakError(*$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter");
924             }
925              
926             # short circuit if seeking to current offset
927 54 100       212 return 1 if $target == $here ;
928              
929             # Outlaw any attempt to seek backwards
930 38 100       186 $self->croakError(*$self->{ClassName} . "::seek: cannot seek backwards")
931             if $target < $here ;
932              
933             # Walk the file to the new offset
934 27         58 my $offset = $target - $here ;
935              
936 27         50 my $buffer ;
937 27 50       136 defined $self->syswrite("\x00" x $offset)
938             or return 0;
939              
940 27         159 return 1 ;
941             }
942              
943             sub binmode
944             {
945 5     5 1 26 1;
946             # my $self = shift ;
947             # return defined *$self->{FH}
948             # ? binmode *$self->{FH}
949             # : 1 ;
950             }
951              
952             sub fileno
953             {
954 30     30 0 4143 my $self = shift ;
955             return defined *$self->{FH}
956             ? *$self->{FH}->fileno()
957 30 100       421 : undef ;
958             }
959              
960             sub opened
961             {
962 10     10 1 1949 my $self = shift ;
963 10         57 return ! *$self->{Closed} ;
964             }
965              
966             sub autoflush
967             {
968 20     20 0 2481 my $self = shift ;
969             return defined *$self->{FH}
970 20 100       175 ? *$self->{FH}->autoflush(@_)
971             : undef ;
972             }
973              
974             sub input_line_number
975             {
976 10     10 0 108 return undef ;
977             }
978              
979              
980             sub _notAvailable
981             {
982 690     690   1250 my $name = shift ;
983 690     30   2548 return sub { Carp::croak "$name Not Available: File opened only for output" ; } ;
  30         14646  
984             }
985              
986             {
987 115     115   983 no warnings 'once';
  115         294  
  115         38073  
988              
989             *read = _notAvailable('read');
990             *READ = _notAvailable('read');
991             *readline = _notAvailable('readline');
992             *READLINE = _notAvailable('readline');
993             *getc = _notAvailable('getc');
994             *GETC = _notAvailable('getc');
995              
996             *FILENO = \&fileno;
997             *PRINT = \&print;
998             *PRINTF = \&printf;
999             *WRITE = \&syswrite;
1000             *write = \&syswrite;
1001             *SEEK = \&seek;
1002             *TELL = \&tell;
1003             *EOF = \&eof;
1004             *CLOSE = \&close;
1005             *BINMODE = \&binmode;
1006             }
1007              
1008             #*sysread = \&_notAvailable;
1009             #*syswrite = \&_write;
1010              
1011             1;
1012              
1013             __END__
1014              
1015             =head1 NAME
1016              
1017             IO::Compress::Base - Base Class for IO::Compress modules
1018              
1019             =head1 SYNOPSIS
1020              
1021             use IO::Compress::Base ;
1022              
1023             =head1 DESCRIPTION
1024              
1025             This module is not intended for direct use in application code. Its sole
1026             purpose is to be sub-classed by IO::Compress modules.
1027              
1028             =head1 SUPPORT
1029              
1030             General feedback/questions/bug reports should be sent to
1031             L<https://github.com/pmqs/IO-Compress/issues> (preferred) or
1032             L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>.
1033              
1034             =head1 SEE ALSO
1035              
1036             L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
1037              
1038             L<IO::Compress::FAQ|IO::Compress::FAQ>
1039              
1040             L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
1041             L<Archive::Tar|Archive::Tar>,
1042             L<IO::Zlib|IO::Zlib>
1043              
1044             =head1 AUTHOR
1045              
1046             This module was written by Paul Marquess, C<pmqs@cpan.org>.
1047              
1048             =head1 MODIFICATION HISTORY
1049              
1050             See the Changes file.
1051              
1052             =head1 COPYRIGHT AND LICENSE
1053              
1054             Copyright (c) 2005-2026 Paul Marquess. All rights reserved.
1055              
1056             This program is free software; you can redistribute it and/or
1057             modify it under the same terms as Perl itself.