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