20adb0e19dacf6459903973fdfae5f2e0c7b48d8
[perl.git] / cpan / IO-Compress / lib / IO / Compress / Base.pm
1
2 package IO::Compress::Base ;
3
4 require 5.006 ;
5
6 use strict ;
7 use warnings;
8
9 use IO::Compress::Base::Common 2.068 ;
10
11 use IO::File (); ;
12 use Scalar::Util ();
13
14 #use File::Glob;
15 #require Exporter ;
16 use Carp() ;
17 use Symbol();
18 #use bytes;
19
20 our (@ISA, $VERSION);
21 @ISA    = qw(Exporter IO::File);
22
23 $VERSION = '2.068';
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     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]);
51     Carp::croak $_[0];
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 ;
95         seek(*$self->{FH}, $offset, IO::Handle::SEEK_SET)
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, $!, $!) ;
99         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         substr(${ *$self->{Buffer} }, $offset, length($data)) = $data ;
104     }
105
106     return 1;
107 }
108
109 sub outputPayload
110 {
111
112     my $self = shift ;
113     return $self->output(@_);
114 }
115
116
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
126     if ( *$self->{FilterContainer} ) {
127         *_ = \$data;
128         &{ *$self->{FilterContainer} }();
129     }
130
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         }
139     }
140
141     return 1;
142 }
143
144 sub getOneShotParams
145 {
146     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     my $self = shift ;
164     my $class = shift ;
165
166     my $got = shift || IO::Compress::Base::Parameters::new();
167
168     $got->parse(
169         {
170             %PARAMS,
171
172
173             $self->getExtraParams(),
174             *$self->{OneShot} ? $self->getOneShotParams() 
175                               : (),
176         }, 
177         @_) or $self->croakError("${class}: " . $got->getError())  ;
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
203     my $lax = ! $got->getValue('strict') ;
204
205     my $outType = IO::Compress::Base::Common::whatIsOutput($outValue);
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
219     my $merge = $got->getValue('merge') ;
220     my $appendOutput = $got->getValue('append') || $merge ;
221     *$obj->{Append} = $appendOutput;
222     *$obj->{FilterContainer} = $got->getValue('filtercontainer') ;
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
233     #no warnings;
234     #if ($outType eq 'filename' && -e $outValue && ! -w _)
235     #  { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) }
236
237     $obj->ckParams($got)
238         or $obj->croakError("${class}: " . $obj->error());
239
240     if ($got->getValue('encode')) { 
241         my $want_encoding = $got->getValue('encode');
242         *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding);
243         my $x = *$obj->{Encoding}; 
244     }
245     else {
246         *$obj->{Encoding} = undef; 
247     }
248     
249     $obj->saveStatus(STATUS_OK) ;
250
251     my $status ;
252     if (! $merge)
253     {
254         *$obj->{Compress} = $obj->mkComp($got)
255             or return undef;
256         
257         *$obj->{UnCompSize} = new U64 ;
258         *$obj->{CompSize} = new U64 ;
259
260         if ( $outType eq 'buffer') {
261             ${ *$obj->{Buffer} }  = ''
262                 unless $appendOutput ;
263         }
264         else {
265             if ($outType eq 'handle') {
266                 *$obj->{FH} = $outValue ;
267                 setBinModeOutput(*$obj->{FH}) ;
268                 #$outValue->flush() ;
269                 *$obj->{Handle} = 1 ;
270                 if ($appendOutput)
271                 {
272                     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                 no warnings;
279                 my $mode = '>' ;
280                 $mode = '>>'
281                     if $appendOutput;
282                 *$obj->{FH} = new IO::File "$mode $outValue" 
283                     or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ;
284                 *$obj->{StdIO} = ($outValue eq '-'); 
285                 setBinModeOutput(*$obj->{FH}) ;
286             }
287         }
288
289         *$obj->{Header} = $obj->mkHeader($got) ;
290         $obj->output( *$obj->{Header} )
291             or return undef;
292         $obj->beforePayload();
293     }
294     else
295     {
296         *$obj->{Compress} = $obj->createMerge($outValue, $outType)
297             or return undef;
298     }
299
300     *$obj->{Closed} = 0 ;
301     *$obj->{AutoClose} = $got->getValue('autoclose') ;
302     *$obj->{Output} = $outValue;
303     *$obj->{ClassName} = $class;
304     *$obj->{Got} = $got;
305     *$obj->{OneShot} = 0 ;
306
307     return $obj ;
308 }
309
310 sub ckOutputParam 
311 {
312     my $self = shift ;
313     my $from = shift ;
314     my $outType = IO::Compress::Base::Common::whatIsOutput($_[0]);
315
316     $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         if $outType eq 'buffer' && Scalar::Util::readonly(${ $_[0] });
324     
325     return 1;    
326 }
327
328
329 sub _def
330 {
331     my $obj = shift ;
332     
333     my $class= (caller)[0] ;
334     my $name = (caller(1))[3] ;
335
336     $obj->croakError("$name: expected at least 1 parameters\n")
337         unless @_ >= 1 ;
338
339     my $input = shift ;
340     my $haveOut = @_ ;
341     my $output = shift ;
342
343     my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output)
344         or return undef ;
345
346     push @_, $output if $haveOut && $x->{Hash};
347
348     *$obj->{OneShot} = 1 ;
349
350     my $got = $obj->checkParams($name, undef, @_)
351         or return undef ;
352
353     $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     if ($x->{GlobMap})
370     {
371         $x->{oneInput} = 1 ;
372         foreach my $pair (@{ $x->{Pairs} })
373         {
374             my ($from, $to) = @$pair ;
375             $obj->_singleTarget($x, 1, $from, $to, @_)
376                 or return undef ;
377         }
378
379         return scalar @{ $x->{Pairs} } ;
380     }
381
382     if (! $x->{oneOutput} )
383     {
384         my $inFile = ($x->{inType} eq 'filenames' 
385                         || $x->{inType} eq 'filename');
386
387         $x->{inType} = $inFile ? 'filename' : 'buffer';
388         
389         foreach my $in ($x->{oneInput} ? $input : @$input)
390         {
391             my $out ;
392             $x->{oneInput} = 1 ;
393
394             $obj->_singleTarget($x, $inFile, $in, \$out, @_)
395                 or return undef ;
396
397             push @$output, \$out ;
398             #if ($x->{outType} eq 'array')
399             #  { push @$output, \$out }
400             #else
401             #  { $output->{$in} = \$out }
402         }
403
404         return 1 ;
405     }
406
407     # finally the 1 to 1 and n to 1
408     return $obj->_singleTarget($x, 1, $input, $output, @_);
409
410     Carp::croak "should not be here" ;
411 }
412
413 sub _singleTarget
414 {
415     my $obj             = shift ;
416     my $x               = shift ;
417     my $inputIsFilename = shift;
418     my $input           = shift;
419     
420     if ($x->{oneInput})
421     {
422         $obj->getFileInfo($x->{Got}, $input)
423             if isaScalar($input) || (isaFilename($input) and $inputIsFilename) ;
424
425         my $z = $obj->_create($x->{Got}, @_)
426             or return undef ;
427
428
429         defined $z->_wr2($input, $inputIsFilename) 
430             or return $z->closeError(undef) ;
431
432         return $z->close() ;
433     }
434     else
435     {
436         my $afterFirst = 0 ;
437         my $inputIsFilename = ($x->{inType} ne 'array');
438         my $keep = $x->{Got}->clone();
439
440         #for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
441         for my $element ( @$input)
442         {
443             my $isFilename = isaFilename($element);
444
445             if ( $afterFirst ++ )
446             {
447                 defined addInterStream($obj, $element, $isFilename)
448                     or return $obj->closeError(undef) ;
449             }
450             else
451             {
452                 $obj->getFileInfo($x->{Got}, $element)
453                     if isaScalar($element) || $isFilename;
454
455                 $obj->_create($x->{Got}, @_)
456                     or return undef ;
457             }
458
459             defined $obj->_wr2($element, $isFilename) 
460                 or return $obj->closeError(undef) ;
461
462             *$obj->{Got} = $keep->clone();
463         }
464         return $obj->close() ;
465     }
466
467 }
468
469 sub _wr2
470 {
471     my $self = shift ;
472
473     my $source = shift ;
474     my $inputIsFilename = shift;
475
476     my $input = $source ;
477     if (! $inputIsFilename)
478     {
479         $input = \$source 
480             if ! ref $source;
481     }
482
483     if ( ref $input && ref $input eq 'SCALAR' )
484     {
485         return $self->syswrite($input, @_) ;
486     }
487
488     if ( ! ref $input  || isaFilehandle($input))
489     {
490         my $isFilehandle = isaFilehandle($input) ;
491
492         my $fh = $input ;
493
494         if ( ! $isFilehandle )
495         {
496             $fh = new IO::File "<$input"
497                 or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ;
498         }
499         binmode $fh if *$self->{Got}->valueOrDefault('binmodein') ;
500
501         my $status ;
502         my $buff ;
503         my $count = 0 ;
504         while ($status = read($fh, $buff, 16 * 1024)) {
505             $count += length $buff;
506             defined $self->syswrite($buff, @_) 
507                 or return undef ;
508         }
509
510         return $self->saveErrorString(undef, $!, $!) 
511             if ! defined $status ;
512
513         if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-')
514         {    
515             $fh->close() 
516                 or return undef ;
517         }
518
519         return $count ;
520     }
521
522     Carp::croak "Should not be here";
523     return undef;
524 }
525
526 sub addInterStream
527 {
528     my $self = shift ;
529     my $input = shift ;
530     my $inputIsFilename = shift ;
531
532     if (*$self->{Got}->getValue('multistream'))
533     {
534         $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         return $self->newStream();
540     }
541     elsif (*$self->{Got}->getValue('autoflush'))
542     {
543         #return $self->flush(Z_FULL_FLUSH);
544     }
545
546     return 1 ;
547 }
548
549 sub getFileInfo
550 {
551 }
552
553 sub TIEHANDLE
554 {
555     return $_[0] if ref($_[0]);
556     die "OOPS\n" ;
557 }
558   
559 sub UNTIE
560 {
561     my $self = shift ;
562 }
563
564 sub DESTROY
565 {
566     my $self = shift ;
567     local ($., $@, $!, $^E, $?);
568     
569     $self->close() ;
570
571     # TODO - memory leak with 5.8.0 - this isn't called until 
572     #        global destruction
573     #
574     %{ *$self } = () ;
575     undef $self ;
576 }
577
578
579
580 sub filterUncompressed
581 {
582 }
583
584 sub syswrite
585 {
586     my $self = shift ;
587
588     my $buffer ;
589     if (ref $_[0] ) {
590         $self->croakError( *$self->{ClassName} . "::write: not a scalar reference" )
591             unless ref $_[0] eq 'SCALAR' ;
592         $buffer = $_[0] ;
593     }
594     else {
595         $buffer = \$_[0] ;
596     }
597
598     if (@_ > 1) {
599         my $slen = defined $$buffer ? length($$buffer) : 0;
600         my $len = $slen;
601         my $offset = 0;
602         $len = $_[1] if $_[1] < $len;
603
604         if (@_ > 2) {
605             $offset = $_[2] || 0;
606             $self->croakError(*$self->{ClassName} . "::write: offset outside string") 
607                 if $offset > $slen;
608             if ($offset < 0) {
609                 $offset += $slen;
610                 $self->croakError( *$self->{ClassName} . "::write: offset outside string") if $offset < 0;
611             }
612             my $rem = $slen - $offset;
613             $len = $rem if $rem < $len;
614         }
615
616         $buffer = \substr($$buffer, $offset, $len) ;
617     }
618
619     return 0 if (! defined $$buffer || length $$buffer == 0) && ! *$self->{FlushPending};
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     if (*$self->{Encoding}) {      
630         $$buffer = *$self->{Encoding}->encode($$buffer);
631     }
632     else {
633         $] >= 5.008 and ( utf8::downgrade($$buffer, 1) 
634             or Carp::croak "Wide character in " .  *$self->{ClassName} . "::write:");
635     }
636
637     $self->filterUncompressed($buffer);
638
639     my $buffer_length = defined $$buffer ? length($$buffer) : 0 ;
640     *$self->{UnCompSize}->add($buffer_length) ;
641
642     my $outBuffer='';
643     my $status = *$self->{Compress}->compr($buffer, $outBuffer) ;
644
645     return $self->saveErrorString(undef, *$self->{Compress}{Error}, 
646                                          *$self->{Compress}{ErrorNo})
647         if $status == STATUS_ERROR;
648
649     *$self->{CompSize}->add(length $outBuffer) ;
650
651     $self->outputPayload($outBuffer)
652         or return undef;
653
654     return $buffer_length;
655 }
656
657 sub print
658 {
659     my $self = shift;
660
661     #if (ref $self) {
662     #    $self = *$self{GLOB} ;
663     #}
664
665     if (defined $\) {
666         if (defined $,) {
667             defined $self->syswrite(join($,, @_) . $\);
668         } else {
669             defined $self->syswrite(join("", @_) . $\);
670         }
671     } else {
672         if (defined $,) {
673             defined $self->syswrite(join($,, @_));
674         } else {
675             defined $self->syswrite(join("", @_));
676         }
677     }
678 }
679
680 sub printf
681 {
682     my $self = shift;
683     my $fmt = shift;
684     defined $self->syswrite(sprintf($fmt, @_));
685 }
686
687 sub _flushCompressed
688 {
689     my $self = shift ;
690
691     my $outBuffer='';
692     my $status = *$self->{Compress}->flush($outBuffer, @_) ;
693     return $self->saveErrorString(0, *$self->{Compress}{Error}, 
694                                     *$self->{Compress}{ErrorNo})
695         if $status == STATUS_ERROR;
696
697     if ( defined *$self->{FH} ) {
698         *$self->{FH}->clearerr();
699     }
700
701     *$self->{CompSize}->add(length $outBuffer) ;
702
703     $self->outputPayload($outBuffer)
704         or return 0;
705     return 1;        
706 }
707
708 sub flush
709 {   
710     my $self = shift ;
711
712     $self->_flushCompressed(@_)
713         or return 0;        
714
715     if ( defined *$self->{FH} ) {
716         defined *$self->{FH}->flush()
717             or return $self->saveErrorString(0, $!, $!); 
718     }
719
720     return 1;
721 }
722
723 sub beforePayload
724 {
725 }
726
727 sub _newStream
728 {
729     my $self = shift ;
730     my $got  = shift;
731
732     my $class = ref $self;
733
734     $self->_writeTrailer()
735         or return 0 ;
736
737     $self->ckParams($got)
738         or $self->croakError("newStream: $self->{Error}");
739
740     if ($got->getValue('encode')) { 
741         my $want_encoding = $got->getValue('encode');
742         *$self->{Encoding} = IO::Compress::Base::Common::getEncoding($self, $class, $want_encoding);
743     }
744     else {
745         *$self->{Encoding} = undef;
746     }
747     
748     *$self->{Compress} = $self->mkComp($got)
749         or return 0;
750
751     *$self->{Header} = $self->mkHeader($got) ;
752     $self->output(*$self->{Header} )
753         or return 0;
754     
755     *$self->{UnCompSize}->reset();
756     *$self->{CompSize}->reset();
757
758     $self->beforePayload();
759
760     return 1 ;
761 }
762
763 sub newStream
764 {
765     my $self = shift ;
766   
767     my $got = $self->checkParams('newStream', *$self->{Got}, @_)
768         or return 0 ;    
769
770     $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     my $self = shift ;
790     return *$self->{Compress}->reset() ;
791 }
792
793 sub _writeTrailer
794 {
795     my $self = shift ;
796
797     my $trailer = '';
798
799     my $status = *$self->{Compress}->close($trailer) ;
800     return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo})
801         if $status == STATUS_ERROR;
802
803     *$self->{CompSize}->add(length $trailer) ;
804
805     $trailer .= $self->mkTrailer();
806     defined $trailer
807       or return 0;
808
809     return $self->output($trailer);
810 }
811
812 sub _writeFinalTrailer
813 {
814     my $self = shift ;
815
816     return $self->output($self->mkFinalTrailer());
817 }
818
819 sub close
820 {
821     my $self = shift ;
822     return 1 if *$self->{Closed} || ! *$self->{Compress} ;
823     *$self->{Closed} = 1 ;
824
825     untie *$self 
826         if $] >= 5.008 ;
827
828     *$self->{FlushPending} = 1 ;
829     $self->_writeTrailer()
830         or return 0 ;
831
832     $self->_writeFinalTrailer()
833         or return 0 ;
834
835     $self->output( "", 1 )
836         or return 0;
837
838     if (defined *$self->{FH}) {
839
840         if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
841             $! = 0 ;
842             *$self->{FH}->close()
843                 or return $self->saveErrorString(0, $!, $!); 
844         }
845         delete *$self->{FH} ;
846         # This delete can set $! in older Perls, so reset the errno
847         $! = 0 ;
848     }
849
850     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     my $self = shift ;
892
893     return *$self->{UnCompSize}->get32bit() ;
894 }
895
896 sub eof
897 {
898     my $self = shift ;
899
900     return *$self->{Closed} ;
901 }
902
903
904 sub seek
905 {
906     my $self     = shift ;
907     my $position = shift;
908     my $whence   = shift ;
909
910     my $here = $self->tell() ;
911     my $target = 0 ;
912
913     #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
914     use IO::Handle ;
915
916     if ($whence == IO::Handle::SEEK_SET) {
917         $target = $position ;
918     }
919     elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) {
920         $target = $here + $position ;
921     }
922     else {
923         $self->croakError(*$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter");
924     }
925
926     # short circuit if seeking to current offset
927     return 1 if $target == $here ;    
928
929     # Outlaw any attempt to seek backwards
930     $self->croakError(*$self->{ClassName} . "::seek: cannot seek backwards")
931         if $target < $here ;
932
933     # Walk the file to the new offset
934     my $offset = $target - $here ;
935
936     my $buffer ;
937     defined $self->syswrite("\x00" x $offset)
938         or return 0;
939
940     return 1 ;
941 }
942
943 sub binmode
944 {
945     1;
946 #    my $self     = shift ;
947 #    return defined *$self->{FH} 
948 #            ? binmode *$self->{FH} 
949 #            : 1 ;
950 }
951
952 sub fileno
953 {
954     my $self     = shift ;
955     return defined *$self->{FH} 
956             ? *$self->{FH}->fileno() 
957             : undef ;
958 }
959
960 sub opened
961 {
962     my $self     = shift ;
963     return ! *$self->{Closed} ;
964 }
965
966 sub autoflush
967 {
968     my $self     = shift ;
969     return defined *$self->{FH} 
970             ? *$self->{FH}->autoflush(@_) 
971             : undef ;
972 }
973
974 sub input_line_number
975 {
976     return undef ;
977 }
978
979
980 sub _notAvailable
981 {
982     my $name = shift ;
983     return sub { Carp::croak "$name Not Available: File opened only for output" ; } ;
984 }
985
986 *read     = _notAvailable('read');
987 *READ     = _notAvailable('read');
988 *readline = _notAvailable('readline');
989 *READLINE = _notAvailable('readline');
990 *getc     = _notAvailable('getc');
991 *GETC     = _notAvailable('getc');
992
993 *FILENO   = \&fileno;
994 *PRINT    = \&print;
995 *PRINTF   = \&printf;
996 *WRITE    = \&syswrite;
997 *write    = \&syswrite;
998 *SEEK     = \&seek; 
999 *TELL     = \&tell;
1000 *EOF      = \&eof;
1001 *CLOSE    = \&close;
1002 *BINMODE  = \&binmode;
1003
1004 #*sysread  = \&_notAvailable;
1005 #*syswrite = \&_write;
1006
1007 1; 
1008
1009 __END__
1010
1011 =head1 NAME
1012
1013 IO::Compress::Base - Base Class for IO::Compress modules 
1014
1015 =head1 SYNOPSIS
1016
1017     use IO::Compress::Base ;
1018
1019 =head1 DESCRIPTION
1020
1021 This module is not intended for direct use in application code. Its sole
1022 purpose is to be sub-classed by IO::Compress modules.
1023
1024 =head1 SEE ALSO
1025
1026 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>
1027
1028 L<IO::Compress::FAQ|IO::Compress::FAQ>
1029
1030 L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
1031 L<Archive::Tar|Archive::Tar>,
1032 L<IO::Zlib|IO::Zlib>
1033
1034 =head1 AUTHOR
1035
1036 This module was written by Paul Marquess, F<pmqs@cpan.org>. 
1037
1038 =head1 MODIFICATION HISTORY
1039
1040 See the Changes file.
1041
1042 =head1 COPYRIGHT AND LICENSE
1043
1044 Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
1045
1046 This program is free software; you can redistribute it and/or
1047 modify it under the same terms as Perl itself.
1048