Commit | Line | Data |
---|---|---|
25f0751f PM |
1 | |
2 | package IO::Compress::Base ; | |
3 | ||
422d6414 | 4 | require 5.006 ; |
25f0751f PM |
5 | |
6 | use strict ; | |
7 | use warnings; | |
8 | ||
a3646257 | 9 | use IO::Compress::Base::Common 2.058 ; |
25f0751f | 10 | |
be0289ac CBW |
11 | use IO::File (); ; |
12 | use Scalar::Util (); | |
25f0751f PM |
13 | |
14 | #use File::Glob; | |
15 | #require Exporter ; | |
c23ee15d CBW |
16 | use Carp() ; |
17 | use Symbol(); | |
25f0751f PM |
18 | use bytes; |
19 | ||
4e7676c7 | 20 | our (@ISA, $VERSION); |
93d092e2 | 21 | @ISA = qw(Exporter IO::File); |
25f0751f | 22 | |
a3646257 | 23 | $VERSION = '2.058'; |
25f0751f PM |
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 | ||
25f0751f PM |
27 | sub saveStatus |
28 | { | |
29 | my $self = shift ; | |
30 | ${ *$self->{ErrorNo} } = shift() + 0 ; | |
31 | ${ *$self->{Error} } = '' ; | |
32 | ||
33 | return ${ *$self->{ErrorNo} } ; | |
34 | } | |
35 | ||
36 | ||
37 | sub saveErrorString | |
38 | { | |
39 | my $self = shift ; | |
40 | my $retval = shift ; | |
41 | ${ *$self->{Error} } = shift ; | |
42 | ${ *$self->{ErrorNo} } = shift() + 0 if @_ ; | |
43 | ||
44 | return $retval; | |
45 | } | |
46 | ||
47 | sub croakError | |
48 | { | |
49 | my $self = shift ; | |
50 | $self->saveErrorString(0, $_[0]); | |
c23ee15d | 51 | Carp::croak $_[0]; |
25f0751f PM |
52 | } |
53 | ||
54 | sub closeError | |
55 | { | |
56 | my $self = shift ; | |
57 | my $retval = shift ; | |
58 | ||
59 | my $errno = *$self->{ErrorNo}; | |
60 | my $error = ${ *$self->{Error} }; | |
61 | ||
62 | $self->close(); | |
63 | ||
64 | *$self->{ErrorNo} = $errno ; | |
65 | ${ *$self->{Error} } = $error ; | |
66 | ||
67 | return $retval; | |
68 | } | |
69 | ||
70 | ||
71 | ||
72 | sub error | |
73 | { | |
74 | my $self = shift ; | |
75 | return ${ *$self->{Error} } ; | |
76 | } | |
77 | ||
78 | sub errorNo | |
79 | { | |
80 | my $self = shift ; | |
81 | return ${ *$self->{ErrorNo} } ; | |
82 | } | |
83 | ||
84 | ||
85 | sub writeAt | |
86 | { | |
87 | my $self = shift ; | |
88 | my $offset = shift; | |
89 | my $data = shift; | |
90 | ||
91 | if (defined *$self->{FH}) { | |
92 | my $here = tell(*$self->{FH}); | |
93 | return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) | |
94 | if $here < 0 ; | |
be0289ac | 95 | seek(*$self->{FH}, $offset, IO::Handle::SEEK_SET) |
25f0751f PM |
96 | or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; |
97 | defined *$self->{FH}->write($data, length $data) | |
98 | or return $self->saveErrorString(undef, $!, $!) ; | |
be0289ac | 99 | seek(*$self->{FH}, $here, IO::Handle::SEEK_SET) |
25f0751f PM |
100 | or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; |
101 | } | |
102 | else { | |
103 | substr(${ *$self->{Buffer} }, $offset, length($data)) = $data ; | |
104 | } | |
105 | ||
106 | return 1; | |
107 | } | |
108 | ||
529174d6 CBW |
109 | sub outputPayload |
110 | { | |
111 | ||
112 | my $self = shift ; | |
113 | return $self->output(@_); | |
114 | } | |
115 | ||
116 | ||
e7d45986 PM |
117 | sub output |
118 | { | |
119 | my $self = shift ; | |
120 | my $data = shift ; | |
121 | my $last = shift ; | |
122 | ||
123 | return 1 | |
124 | if length $data == 0 && ! $last ; | |
125 | ||
ad4795e7 | 126 | if ( *$self->{FilterContainer} ) { |
e7d45986 | 127 | *_ = \$data; |
ad4795e7 | 128 | &{ *$self->{FilterContainer} }(); |
e7d45986 PM |
129 | } |
130 | ||
d54256af PM |
131 | if (length $data) { |
132 | if ( defined *$self->{FH} ) { | |
133 | defined *$self->{FH}->write( $data, length $data ) | |
134 | or return $self->saveErrorString(0, $!, $!); | |
135 | } | |
136 | else { | |
137 | ${ *$self->{Buffer} } .= $data ; | |
138 | } | |
e7d45986 PM |
139 | } |
140 | ||
141 | return 1; | |
142 | } | |
143 | ||
25f0751f PM |
144 | sub getOneShotParams |
145 | { | |
be0289ac | 146 | return ( 'multistream' => [IO::Compress::Base::Common::Parse_boolean, 1], |
25f0751f PM |
147 | ); |
148 | } | |
149 | ||
be0289ac CBW |
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 | ||
25f0751f PM |
161 | sub checkParams |
162 | { | |
163 | my $self = shift ; | |
164 | my $class = shift ; | |
165 | ||
166 | my $got = shift || IO::Compress::Base::Parameters::new(); | |
167 | ||
168 | $got->parse( | |
169 | { | |
be0289ac | 170 | %PARAMS, |
25f0751f | 171 | |
e7d45986 | 172 | |
25f0751f PM |
173 | $self->getExtraParams(), |
174 | *$self->{OneShot} ? $self->getOneShotParams() | |
175 | : (), | |
176 | }, | |
be0289ac | 177 | @_) or $self->croakError("${class}: " . $got->getError()) ; |
25f0751f PM |
178 | |
179 | return $got ; | |
180 | } | |
181 | ||
182 | sub _create | |
183 | { | |
184 | my $obj = shift; | |
185 | my $got = shift; | |
186 | ||
187 | *$obj->{Closed} = 1 ; | |
188 | ||
189 | my $class = ref $obj; | |
190 | $obj->croakError("$class: Missing Output parameter") | |
191 | if ! @_ && ! $got ; | |
192 | ||
193 | my $outValue = shift ; | |
194 | my $oneShot = 1 ; | |
195 | ||
196 | if (! $got) | |
197 | { | |
198 | $oneShot = 0 ; | |
199 | $got = $obj->checkParams($class, undef, @_) | |
200 | or return undef ; | |
201 | } | |
202 | ||
be0289ac | 203 | my $lax = ! $got->getValue('strict') ; |
25f0751f | 204 | |
be0289ac | 205 | my $outType = IO::Compress::Base::Common::whatIsOutput($outValue); |
25f0751f PM |
206 | |
207 | $obj->ckOutputParam($class, $outValue) | |
208 | or return undef ; | |
209 | ||
210 | if ($outType eq 'buffer') { | |
211 | *$obj->{Buffer} = $outValue; | |
212 | } | |
213 | else { | |
214 | my $buff = "" ; | |
215 | *$obj->{Buffer} = \$buff ; | |
216 | } | |
217 | ||
218 | # Merge implies Append | |
be0289ac CBW |
219 | my $merge = $got->getValue('merge') ; |
220 | my $appendOutput = $got->getValue('append') || $merge ; | |
e7d45986 | 221 | *$obj->{Append} = $appendOutput; |
be0289ac | 222 | *$obj->{FilterContainer} = $got->getValue('filtercontainer') ; |
25f0751f PM |
223 | |
224 | if ($merge) | |
225 | { | |
226 | # Switch off Merge mode if output file/buffer is empty/doesn't exist | |
227 | if (($outType eq 'buffer' && length $$outValue == 0 ) || | |
228 | ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) ) | |
229 | { $merge = 0 } | |
230 | } | |
231 | ||
232 | # If output is a file, check that it is writable | |
319fab50 PM |
233 | #no warnings; |
234 | #if ($outType eq 'filename' && -e $outValue && ! -w _) | |
235 | # { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) } | |
25f0751f | 236 | |
a3646257 | 237 | if ($got->getValue('encode')) { |
be0289ac | 238 | my $want_encoding = $got->getValue('encode'); |
4e7676c7 SP |
239 | *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding); |
240 | } | |
25f0751f PM |
241 | |
242 | $obj->ckParams($got) | |
243 | or $obj->croakError("${class}: " . $obj->error()); | |
244 | ||
245 | ||
246 | $obj->saveStatus(STATUS_OK) ; | |
247 | ||
248 | my $status ; | |
249 | if (! $merge) | |
250 | { | |
a1787f24 | 251 | *$obj->{Compress} = $obj->mkComp($got) |
25f0751f PM |
252 | or return undef; |
253 | ||
e7d45986 PM |
254 | *$obj->{UnCompSize} = new U64 ; |
255 | *$obj->{CompSize} = new U64 ; | |
25f0751f PM |
256 | |
257 | if ( $outType eq 'buffer') { | |
258 | ${ *$obj->{Buffer} } = '' | |
259 | unless $appendOutput ; | |
25f0751f PM |
260 | } |
261 | else { | |
262 | if ($outType eq 'handle') { | |
263 | *$obj->{FH} = $outValue ; | |
264 | setBinModeOutput(*$obj->{FH}) ; | |
265 | $outValue->flush() ; | |
266 | *$obj->{Handle} = 1 ; | |
267 | if ($appendOutput) | |
268 | { | |
be0289ac | 269 | seek(*$obj->{FH}, 0, IO::Handle::SEEK_END) |
25f0751f PM |
270 | or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; |
271 | ||
272 | } | |
273 | } | |
274 | elsif ($outType eq 'filename') { | |
319fab50 | 275 | no warnings; |
25f0751f PM |
276 | my $mode = '>' ; |
277 | $mode = '>>' | |
278 | if $appendOutput; | |
279 | *$obj->{FH} = new IO::File "$mode $outValue" | |
280 | or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ; | |
281 | *$obj->{StdIO} = ($outValue eq '-'); | |
282 | setBinModeOutput(*$obj->{FH}) ; | |
283 | } | |
25f0751f | 284 | } |
e7d45986 PM |
285 | |
286 | *$obj->{Header} = $obj->mkHeader($got) ; | |
287 | $obj->output( *$obj->{Header} ) | |
288 | or return undef; | |
529174d6 | 289 | $obj->beforePayload(); |
25f0751f PM |
290 | } |
291 | else | |
292 | { | |
293 | *$obj->{Compress} = $obj->createMerge($outValue, $outType) | |
294 | or return undef; | |
295 | } | |
296 | ||
297 | *$obj->{Closed} = 0 ; | |
be0289ac | 298 | *$obj->{AutoClose} = $got->getValue('autoclose') ; |
25f0751f PM |
299 | *$obj->{Output} = $outValue; |
300 | *$obj->{ClassName} = $class; | |
301 | *$obj->{Got} = $got; | |
302 | *$obj->{OneShot} = 0 ; | |
303 | ||
304 | return $obj ; | |
305 | } | |
306 | ||
307 | sub ckOutputParam | |
308 | { | |
309 | my $self = shift ; | |
310 | my $from = shift ; | |
be0289ac | 311 | my $outType = IO::Compress::Base::Common::whatIsOutput($_[0]); |
25f0751f PM |
312 | |
313 | $self->croakError("$from: output parameter not a filename, filehandle or scalar ref") | |
314 | if ! $outType ; | |
315 | ||
319fab50 PM |
316 | #$self->croakError("$from: output filename is undef or null string") |
317 | #if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ; | |
25f0751f PM |
318 | |
319 | $self->croakError("$from: output buffer is read-only") | |
be0289ac | 320 | if $outType eq 'buffer' && Scalar::Util::readonly(${ $_[0] }); |
25f0751f PM |
321 | |
322 | return 1; | |
323 | } | |
324 | ||
325 | ||
326 | sub _def | |
327 | { | |
328 | my $obj = shift ; | |
329 | ||
330 | my $class= (caller)[0] ; | |
331 | my $name = (caller(1))[3] ; | |
332 | ||
333 | $obj->croakError("$name: expected at least 1 parameters\n") | |
334 | unless @_ >= 1 ; | |
335 | ||
336 | my $input = shift ; | |
337 | my $haveOut = @_ ; | |
338 | my $output = shift ; | |
339 | ||
a1787f24 | 340 | my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output) |
25f0751f PM |
341 | or return undef ; |
342 | ||
343 | push @_, $output if $haveOut && $x->{Hash}; | |
344 | ||
345 | *$obj->{OneShot} = 1 ; | |
346 | ||
347 | my $got = $obj->checkParams($name, undef, @_) | |
348 | or return undef ; | |
349 | ||
350 | $x->{Got} = $got ; | |
351 | ||
352 | # if ($x->{Hash}) | |
353 | # { | |
354 | # while (my($k, $v) = each %$input) | |
355 | # { | |
356 | # $v = \$input->{$k} | |
357 | # unless defined $v ; | |
358 | # | |
359 | # $obj->_singleTarget($x, 1, $k, $v, @_) | |
360 | # or return undef ; | |
361 | # } | |
362 | # | |
363 | # return keys %$input ; | |
364 | # } | |
365 | ||
366 | if ($x->{GlobMap}) | |
367 | { | |
368 | $x->{oneInput} = 1 ; | |
369 | foreach my $pair (@{ $x->{Pairs} }) | |
370 | { | |
371 | my ($from, $to) = @$pair ; | |
372 | $obj->_singleTarget($x, 1, $from, $to, @_) | |
373 | or return undef ; | |
374 | } | |
375 | ||
376 | return scalar @{ $x->{Pairs} } ; | |
377 | } | |
378 | ||
379 | if (! $x->{oneOutput} ) | |
380 | { | |
381 | my $inFile = ($x->{inType} eq 'filenames' | |
382 | || $x->{inType} eq 'filename'); | |
383 | ||
384 | $x->{inType} = $inFile ? 'filename' : 'buffer'; | |
385 | ||
386 | foreach my $in ($x->{oneInput} ? $input : @$input) | |
387 | { | |
388 | my $out ; | |
389 | $x->{oneInput} = 1 ; | |
390 | ||
391 | $obj->_singleTarget($x, $inFile, $in, \$out, @_) | |
392 | or return undef ; | |
393 | ||
394 | push @$output, \$out ; | |
395 | #if ($x->{outType} eq 'array') | |
396 | # { push @$output, \$out } | |
397 | #else | |
398 | # { $output->{$in} = \$out } | |
399 | } | |
400 | ||
401 | return 1 ; | |
402 | } | |
403 | ||
404 | # finally the 1 to 1 and n to 1 | |
405 | return $obj->_singleTarget($x, 1, $input, $output, @_); | |
406 | ||
c23ee15d | 407 | Carp::croak "should not be here" ; |
25f0751f PM |
408 | } |
409 | ||
410 | sub _singleTarget | |
411 | { | |
412 | my $obj = shift ; | |
413 | my $x = shift ; | |
414 | my $inputIsFilename = shift; | |
415 | my $input = shift; | |
416 | ||
417 | if ($x->{oneInput}) | |
418 | { | |
419 | $obj->getFileInfo($x->{Got}, $input) | |
08ad9465 | 420 | if isaScalar($input) || (isaFilename($input) and $inputIsFilename) ; |
25f0751f PM |
421 | |
422 | my $z = $obj->_create($x->{Got}, @_) | |
423 | or return undef ; | |
424 | ||
425 | ||
426 | defined $z->_wr2($input, $inputIsFilename) | |
427 | or return $z->closeError(undef) ; | |
428 | ||
429 | return $z->close() ; | |
430 | } | |
431 | else | |
432 | { | |
433 | my $afterFirst = 0 ; | |
434 | my $inputIsFilename = ($x->{inType} ne 'array'); | |
435 | my $keep = $x->{Got}->clone(); | |
436 | ||
437 | #for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) | |
438 | for my $element ( @$input) | |
439 | { | |
440 | my $isFilename = isaFilename($element); | |
441 | ||
442 | if ( $afterFirst ++ ) | |
443 | { | |
444 | defined addInterStream($obj, $element, $isFilename) | |
445 | or return $obj->closeError(undef) ; | |
446 | } | |
447 | else | |
448 | { | |
449 | $obj->getFileInfo($x->{Got}, $element) | |
08ad9465 | 450 | if isaScalar($element) || $isFilename; |
25f0751f PM |
451 | |
452 | $obj->_create($x->{Got}, @_) | |
453 | or return undef ; | |
454 | } | |
455 | ||
456 | defined $obj->_wr2($element, $isFilename) | |
457 | or return $obj->closeError(undef) ; | |
458 | ||
459 | *$obj->{Got} = $keep->clone(); | |
460 | } | |
461 | return $obj->close() ; | |
462 | } | |
463 | ||
464 | } | |
465 | ||
466 | sub _wr2 | |
467 | { | |
468 | my $self = shift ; | |
469 | ||
470 | my $source = shift ; | |
471 | my $inputIsFilename = shift; | |
472 | ||
473 | my $input = $source ; | |
474 | if (! $inputIsFilename) | |
475 | { | |
476 | $input = \$source | |
477 | if ! ref $source; | |
478 | } | |
479 | ||
480 | if ( ref $input && ref $input eq 'SCALAR' ) | |
481 | { | |
482 | return $self->syswrite($input, @_) ; | |
483 | } | |
484 | ||
485 | if ( ! ref $input || isaFilehandle($input)) | |
486 | { | |
487 | my $isFilehandle = isaFilehandle($input) ; | |
488 | ||
489 | my $fh = $input ; | |
490 | ||
491 | if ( ! $isFilehandle ) | |
492 | { | |
493 | $fh = new IO::File "<$input" | |
494 | or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ; | |
495 | } | |
be0289ac | 496 | binmode $fh if *$self->{Got}->valueOrDefault('binmodein') ; |
25f0751f PM |
497 | |
498 | my $status ; | |
499 | my $buff ; | |
500 | my $count = 0 ; | |
10c2b2bb | 501 | while ($status = read($fh, $buff, 16 * 1024)) { |
25f0751f PM |
502 | $count += length $buff; |
503 | defined $self->syswrite($buff, @_) | |
504 | or return undef ; | |
505 | } | |
506 | ||
507 | return $self->saveErrorString(undef, $!, $!) | |
10c2b2bb | 508 | if ! defined $status ; |
25f0751f PM |
509 | |
510 | if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-') | |
511 | { | |
512 | $fh->close() | |
513 | or return undef ; | |
514 | } | |
515 | ||
516 | return $count ; | |
517 | } | |
518 | ||
c23ee15d | 519 | Carp::croak "Should not be here"; |
25f0751f PM |
520 | return undef; |
521 | } | |
522 | ||
523 | sub addInterStream | |
524 | { | |
525 | my $self = shift ; | |
526 | my $input = shift ; | |
527 | my $inputIsFilename = shift ; | |
528 | ||
be0289ac | 529 | if (*$self->{Got}->getValue('multistream')) |
25f0751f PM |
530 | { |
531 | $self->getFileInfo(*$self->{Got}, $input) | |
532 | #if isaFilename($input) and $inputIsFilename ; | |
08ad9465 | 533 | if isaScalar($input) || isaFilename($input) ; |
25f0751f PM |
534 | |
535 | # TODO -- newStream needs to allow gzip/zip header to be modified | |
536 | return $self->newStream(); | |
537 | } | |
be0289ac | 538 | elsif (*$self->{Got}->getValue('autoflush')) |
25f0751f PM |
539 | { |
540 | #return $self->flush(Z_FULL_FLUSH); | |
541 | } | |
542 | ||
543 | return 1 ; | |
544 | } | |
545 | ||
258133d1 PM |
546 | sub getFileInfo |
547 | { | |
548 | } | |
549 | ||
25f0751f PM |
550 | sub TIEHANDLE |
551 | { | |
552 | return $_[0] if ref($_[0]); | |
553 | die "OOPS\n" ; | |
554 | } | |
555 | ||
556 | sub UNTIE | |
557 | { | |
558 | my $self = shift ; | |
559 | } | |
560 | ||
561 | sub DESTROY | |
562 | { | |
563 | my $self = shift ; | |
e11a3f9e PM |
564 | local ($., $@, $!, $^E, $?); |
565 | ||
25f0751f PM |
566 | $self->close() ; |
567 | ||
568 | # TODO - memory leak with 5.8.0 - this isn't called until | |
569 | # global destruction | |
570 | # | |
571 | %{ *$self } = () ; | |
572 | undef $self ; | |
573 | } | |
574 | ||
575 | ||
576 | ||
2b4e0969 PM |
577 | sub filterUncompressed |
578 | { | |
579 | } | |
580 | ||
25f0751f PM |
581 | sub syswrite |
582 | { | |
583 | my $self = shift ; | |
584 | ||
585 | my $buffer ; | |
586 | if (ref $_[0] ) { | |
587 | $self->croakError( *$self->{ClassName} . "::write: not a scalar reference" ) | |
588 | unless ref $_[0] eq 'SCALAR' ; | |
589 | $buffer = $_[0] ; | |
590 | } | |
591 | else { | |
592 | $buffer = \$_[0] ; | |
593 | } | |
594 | ||
93d092e2 | 595 | $] >= 5.008 and ( utf8::downgrade($$buffer, 1) |
c23ee15d | 596 | or Carp::croak "Wide character in " . *$self->{ClassName} . "::write:"); |
93d092e2 | 597 | |
25f0751f PM |
598 | |
599 | if (@_ > 1) { | |
600 | my $slen = defined $$buffer ? length($$buffer) : 0; | |
601 | my $len = $slen; | |
602 | my $offset = 0; | |
603 | $len = $_[1] if $_[1] < $len; | |
604 | ||
605 | if (@_ > 2) { | |
606 | $offset = $_[2] || 0; | |
607 | $self->croakError(*$self->{ClassName} . "::write: offset outside string") | |
608 | if $offset > $slen; | |
609 | if ($offset < 0) { | |
610 | $offset += $slen; | |
611 | $self->croakError( *$self->{ClassName} . "::write: offset outside string") if $offset < 0; | |
612 | } | |
613 | my $rem = $slen - $offset; | |
614 | $len = $rem if $rem < $len; | |
615 | } | |
616 | ||
617 | $buffer = \substr($$buffer, $offset, $len) ; | |
618 | } | |
619 | ||
620 | return 0 if ! defined $$buffer || length $$buffer == 0 ; | |
621 | ||
4e7676c7 SP |
622 | if (*$self->{Encoding}) { |
623 | $$buffer = *$self->{Encoding}->encode($$buffer); | |
624 | } | |
25f0751f | 625 | |
2b4e0969 PM |
626 | $self->filterUncompressed($buffer); |
627 | ||
4e7676c7 SP |
628 | my $buffer_length = defined $$buffer ? length($$buffer) : 0 ; |
629 | *$self->{UnCompSize}->add($buffer_length) ; | |
25f0751f | 630 | |
e7d45986 PM |
631 | my $outBuffer=''; |
632 | my $status = *$self->{Compress}->compr($buffer, $outBuffer) ; | |
25f0751f PM |
633 | |
634 | return $self->saveErrorString(undef, *$self->{Compress}{Error}, | |
635 | *$self->{Compress}{ErrorNo}) | |
636 | if $status == STATUS_ERROR; | |
637 | ||
e7d45986 | 638 | *$self->{CompSize}->add(length $outBuffer) ; |
25f0751f | 639 | |
529174d6 | 640 | $self->outputPayload($outBuffer) |
e7d45986 | 641 | or return undef; |
25f0751f PM |
642 | |
643 | return $buffer_length; | |
644 | } | |
645 | ||
646 | sub print | |
647 | { | |
648 | my $self = shift; | |
649 | ||
650 | #if (ref $self) { | |
651 | # $self = *$self{GLOB} ; | |
652 | #} | |
653 | ||
654 | if (defined $\) { | |
655 | if (defined $,) { | |
656 | defined $self->syswrite(join($,, @_) . $\); | |
657 | } else { | |
658 | defined $self->syswrite(join("", @_) . $\); | |
659 | } | |
660 | } else { | |
661 | if (defined $,) { | |
662 | defined $self->syswrite(join($,, @_)); | |
663 | } else { | |
664 | defined $self->syswrite(join("", @_)); | |
665 | } | |
666 | } | |
667 | } | |
668 | ||
669 | sub printf | |
670 | { | |
671 | my $self = shift; | |
672 | my $fmt = shift; | |
673 | defined $self->syswrite(sprintf($fmt, @_)); | |
674 | } | |
675 | ||
676 | ||
677 | ||
678 | sub flush | |
a3646257 | 679 | { |
25f0751f PM |
680 | my $self = shift ; |
681 | ||
e7d45986 PM |
682 | my $outBuffer=''; |
683 | my $status = *$self->{Compress}->flush($outBuffer, @_) ; | |
25f0751f PM |
684 | return $self->saveErrorString(0, *$self->{Compress}{Error}, |
685 | *$self->{Compress}{ErrorNo}) | |
686 | if $status == STATUS_ERROR; | |
687 | ||
688 | if ( defined *$self->{FH} ) { | |
689 | *$self->{FH}->clearerr(); | |
e7d45986 PM |
690 | } |
691 | ||
692 | *$self->{CompSize}->add(length $outBuffer) ; | |
693 | ||
529174d6 | 694 | $self->outputPayload($outBuffer) |
e7d45986 PM |
695 | or return 0; |
696 | ||
697 | if ( defined *$self->{FH} ) { | |
25f0751f PM |
698 | defined *$self->{FH}->flush() |
699 | or return $self->saveErrorString(0, $!, $!); | |
25f0751f PM |
700 | } |
701 | ||
702 | return 1; | |
703 | } | |
704 | ||
529174d6 CBW |
705 | sub beforePayload |
706 | { | |
707 | } | |
708 | ||
422d6414 | 709 | sub _newStream |
25f0751f PM |
710 | { |
711 | my $self = shift ; | |
422d6414 CBW |
712 | my $got = shift; |
713 | ||
25f0751f PM |
714 | $self->_writeTrailer() |
715 | or return 0 ; | |
716 | ||
25f0751f PM |
717 | $self->ckParams($got) |
718 | or $self->croakError("newStream: $self->{Error}"); | |
719 | ||
a1787f24 PM |
720 | *$self->{Compress} = $self->mkComp($got) |
721 | or return 0; | |
722 | ||
25f0751f | 723 | *$self->{Header} = $self->mkHeader($got) ; |
e7d45986 PM |
724 | $self->output(*$self->{Header} ) |
725 | or return 0; | |
25f0751f | 726 | |
e7d45986 PM |
727 | *$self->{UnCompSize}->reset(); |
728 | *$self->{CompSize}->reset(); | |
25f0751f | 729 | |
529174d6 CBW |
730 | $self->beforePayload(); |
731 | ||
25f0751f PM |
732 | return 1 ; |
733 | } | |
734 | ||
422d6414 CBW |
735 | sub newStream |
736 | { | |
737 | my $self = shift ; | |
738 | ||
739 | my $got = $self->checkParams('newStream', *$self->{Got}, @_) | |
740 | or return 0 ; | |
741 | ||
742 | $self->_newStream($got); | |
743 | ||
744 | # *$self->{Compress} = $self->mkComp($got) | |
745 | # or return 0; | |
746 | # | |
747 | # *$self->{Header} = $self->mkHeader($got) ; | |
748 | # $self->output(*$self->{Header} ) | |
749 | # or return 0; | |
750 | # | |
751 | # *$self->{UnCompSize}->reset(); | |
752 | # *$self->{CompSize}->reset(); | |
753 | # | |
754 | # $self->beforePayload(); | |
755 | # | |
756 | # return 1 ; | |
757 | } | |
758 | ||
2b4e0969 PM |
759 | sub reset |
760 | { | |
761 | my $self = shift ; | |
762 | return *$self->{Compress}->reset() ; | |
763 | } | |
764 | ||
25f0751f PM |
765 | sub _writeTrailer |
766 | { | |
767 | my $self = shift ; | |
768 | ||
e7d45986 PM |
769 | my $trailer = ''; |
770 | ||
771 | my $status = *$self->{Compress}->close($trailer) ; | |
25f0751f PM |
772 | return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) |
773 | if $status == STATUS_ERROR; | |
774 | ||
e7d45986 PM |
775 | *$self->{CompSize}->add(length $trailer) ; |
776 | ||
777 | $trailer .= $self->mkTrailer(); | |
25f0751f PM |
778 | defined $trailer |
779 | or return 0; | |
780 | ||
e7d45986 | 781 | return $self->output($trailer); |
25f0751f PM |
782 | } |
783 | ||
784 | sub _writeFinalTrailer | |
785 | { | |
786 | my $self = shift ; | |
787 | ||
e7d45986 | 788 | return $self->output($self->mkFinalTrailer()); |
25f0751f PM |
789 | } |
790 | ||
791 | sub close | |
792 | { | |
793 | my $self = shift ; | |
25f0751f PM |
794 | return 1 if *$self->{Closed} || ! *$self->{Compress} ; |
795 | *$self->{Closed} = 1 ; | |
796 | ||
797 | untie *$self | |
798 | if $] >= 5.008 ; | |
799 | ||
800 | $self->_writeTrailer() | |
801 | or return 0 ; | |
802 | ||
803 | $self->_writeFinalTrailer() | |
804 | or return 0 ; | |
805 | ||
e7d45986 PM |
806 | $self->output( "", 1 ) |
807 | or return 0; | |
808 | ||
25f0751f | 809 | if (defined *$self->{FH}) { |
e7d45986 | 810 | |
25f0751f PM |
811 | #if (! *$self->{Handle} || *$self->{AutoClose}) { |
812 | if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { | |
813 | $! = 0 ; | |
814 | *$self->{FH}->close() | |
815 | or return $self->saveErrorString(0, $!, $!); | |
816 | } | |
817 | delete *$self->{FH} ; | |
818 | # This delete can set $! in older Perls, so reset the errno | |
819 | $! = 0 ; | |
820 | } | |
f6fd7794 | 821 | |
25f0751f PM |
822 | return 1; |
823 | } | |
824 | ||
825 | ||
826 | #sub total_in | |
827 | #sub total_out | |
828 | #sub msg | |
829 | # | |
830 | #sub crc | |
831 | #{ | |
832 | # my $self = shift ; | |
833 | # return *$self->{Compress}->crc32() ; | |
834 | #} | |
835 | # | |
836 | #sub msg | |
837 | #{ | |
838 | # my $self = shift ; | |
839 | # return *$self->{Compress}->msg() ; | |
840 | #} | |
841 | # | |
842 | #sub dict_adler | |
843 | #{ | |
844 | # my $self = shift ; | |
845 | # return *$self->{Compress}->dict_adler() ; | |
846 | #} | |
847 | # | |
848 | #sub get_Level | |
849 | #{ | |
850 | # my $self = shift ; | |
851 | # return *$self->{Compress}->get_Level() ; | |
852 | #} | |
853 | # | |
854 | #sub get_Strategy | |
855 | #{ | |
856 | # my $self = shift ; | |
857 | # return *$self->{Compress}->get_Strategy() ; | |
858 | #} | |
859 | ||
860 | ||
861 | sub tell | |
862 | { | |
863 | my $self = shift ; | |
864 | ||
e7d45986 | 865 | return *$self->{UnCompSize}->get32bit() ; |
25f0751f PM |
866 | } |
867 | ||
868 | sub eof | |
869 | { | |
870 | my $self = shift ; | |
871 | ||
872 | return *$self->{Closed} ; | |
873 | } | |
874 | ||
875 | ||
876 | sub seek | |
877 | { | |
878 | my $self = shift ; | |
879 | my $position = shift; | |
880 | my $whence = shift ; | |
881 | ||
882 | my $here = $self->tell() ; | |
883 | my $target = 0 ; | |
884 | ||
885 | #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); | |
886 | use IO::Handle ; | |
887 | ||
888 | if ($whence == IO::Handle::SEEK_SET) { | |
889 | $target = $position ; | |
890 | } | |
891 | elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) { | |
892 | $target = $here + $position ; | |
893 | } | |
894 | else { | |
895 | $self->croakError(*$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter"); | |
896 | } | |
897 | ||
898 | # short circuit if seeking to current offset | |
899 | return 1 if $target == $here ; | |
900 | ||
901 | # Outlaw any attempt to seek backwards | |
902 | $self->croakError(*$self->{ClassName} . "::seek: cannot seek backwards") | |
903 | if $target < $here ; | |
904 | ||
905 | # Walk the file to the new offset | |
906 | my $offset = $target - $here ; | |
907 | ||
908 | my $buffer ; | |
909 | defined $self->syswrite("\x00" x $offset) | |
910 | or return 0; | |
911 | ||
912 | return 1 ; | |
913 | } | |
914 | ||
915 | sub binmode | |
916 | { | |
917 | 1; | |
918 | # my $self = shift ; | |
919 | # return defined *$self->{FH} | |
920 | # ? binmode *$self->{FH} | |
921 | # : 1 ; | |
922 | } | |
923 | ||
924 | sub fileno | |
925 | { | |
926 | my $self = shift ; | |
927 | return defined *$self->{FH} | |
928 | ? *$self->{FH}->fileno() | |
929 | : undef ; | |
930 | } | |
931 | ||
932 | sub opened | |
933 | { | |
934 | my $self = shift ; | |
935 | return ! *$self->{Closed} ; | |
936 | } | |
937 | ||
938 | sub autoflush | |
939 | { | |
940 | my $self = shift ; | |
941 | return defined *$self->{FH} | |
942 | ? *$self->{FH}->autoflush(@_) | |
943 | : undef ; | |
944 | } | |
945 | ||
946 | sub input_line_number | |
947 | { | |
948 | return undef ; | |
949 | } | |
950 | ||
951 | ||
952 | sub _notAvailable | |
953 | { | |
954 | my $name = shift ; | |
c23ee15d | 955 | return sub { Carp::croak "$name Not Available: File opened only for output" ; } ; |
25f0751f PM |
956 | } |
957 | ||
958 | *read = _notAvailable('read'); | |
959 | *READ = _notAvailable('read'); | |
960 | *readline = _notAvailable('readline'); | |
961 | *READLINE = _notAvailable('readline'); | |
962 | *getc = _notAvailable('getc'); | |
963 | *GETC = _notAvailable('getc'); | |
964 | ||
965 | *FILENO = \&fileno; | |
966 | *PRINT = \&print; | |
967 | *PRINTF = \&printf; | |
968 | *WRITE = \&syswrite; | |
969 | *write = \&syswrite; | |
970 | *SEEK = \&seek; | |
971 | *TELL = \&tell; | |
972 | *EOF = \&eof; | |
973 | *CLOSE = \&close; | |
974 | *BINMODE = \&binmode; | |
975 | ||
976 | #*sysread = \&_notAvailable; | |
977 | #*syswrite = \&_write; | |
978 | ||
979 | 1; | |
980 | ||
981 | __END__ | |
982 | ||
983 | =head1 NAME | |
984 | ||
25f0751f PM |
985 | IO::Compress::Base - Base Class for IO::Compress modules |
986 | ||
25f0751f PM |
987 | =head1 SYNOPSIS |
988 | ||
989 | use IO::Compress::Base ; | |
990 | ||
991 | =head1 DESCRIPTION | |
992 | ||
25f0751f PM |
993 | This module is not intended for direct use in application code. Its sole |
994 | purpose if to to be sub-classed by IO::Compress modules. | |
995 | ||
25f0751f PM |
996 | =head1 SEE ALSO |
997 | ||
9b5fd1d4 | 998 | 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::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> |
25f0751f | 999 | |
08ad9465 | 1000 | L<IO::Compress::FAQ|IO::Compress::FAQ> |
25f0751f PM |
1001 | |
1002 | L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, | |
1003 | L<Archive::Tar|Archive::Tar>, | |
1004 | L<IO::Zlib|IO::Zlib> | |
1005 | ||
25f0751f PM |
1006 | =head1 AUTHOR |
1007 | ||
cb7abd7f | 1008 | This module was written by Paul Marquess, F<pmqs@cpan.org>. |
25f0751f | 1009 | |
25f0751f PM |
1010 | =head1 MODIFICATION HISTORY |
1011 | ||
1012 | See the Changes file. | |
1013 | ||
1014 | =head1 COPYRIGHT AND LICENSE | |
25f0751f | 1015 | |
422d6414 | 1016 | Copyright (c) 2005-2012 Paul Marquess. All rights reserved. |
25f0751f PM |
1017 | |
1018 | This program is free software; you can redistribute it and/or | |
1019 | modify it under the same terms as Perl itself. | |
1020 |