1
2package IO::Compress::Base ;
3
4require 5.006 ;
5
6use strict ;
7use warnings;
8
9use IO::Compress::Base::Common 2.064 ;
10
11use IO::File (); ;
12use Scalar::Util ();
13
14#use File::Glob;
15#require Exporter ;
16use Carp() ;
17use Symbol();
18#use bytes;
19
20our (@ISA, $VERSION);
21@ISA    = qw(Exporter IO::File);
22
23$VERSION = '2.064';
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
27sub saveStatus
28{
29    my $self   = shift ;
30    ${ *$self->{ErrorNo} } = shift() + 0 ;
31    ${ *$self->{Error} } = '' ;
32
33    return ${ *$self->{ErrorNo} } ;
34}
35
36
37sub 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
47sub croakError
48{
49    my $self   = shift ;
50    $self->saveErrorString(0, $_[0]);
51    Carp::croak $_[0];
52}
53
54sub 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
72sub error
73{
74    my $self   = shift ;
75    return ${ *$self->{Error} } ;
76}
77
78sub errorNo
79{
80    my $self   = shift ;
81    return ${ *$self->{ErrorNo} } ;
82}
83
84
85sub 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
109sub outputPayload
110{
111
112    my $self = shift ;
113    return $self->output(@_);
114}
115
116
117sub 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
144sub getOneShotParams
145{
146    return ( 'multistream' => [IO::Compress::Base::Common::Parse_boolean,   1],
147           );
148}
149
150our %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
161sub 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
182sub _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
310sub 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
329sub _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
413sub _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
469sub _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
526sub 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
549sub getFileInfo
550{
551}
552
553sub TIEHANDLE
554{
555    return $_[0] if ref($_[0]);
556    die "OOPS\n" ;
557}
558
559sub UNTIE
560{
561    my $self = shift ;
562}
563
564sub 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
580sub filterUncompressed
581{
582}
583
584sub 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
657sub 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
680sub printf
681{
682    my $self = shift;
683    my $fmt = shift;
684    defined $self->syswrite(sprintf($fmt, @_));
685}
686
687sub _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
708sub 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
723sub beforePayload
724{
725}
726
727sub _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
763sub 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
787sub reset
788{
789    my $self = shift ;
790    return *$self->{Compress}->reset() ;
791}
792
793sub _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
812sub _writeFinalTrailer
813{
814    my $self = shift ;
815
816    return $self->output($self->mkFinalTrailer());
817}
818
819sub 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
889sub tell
890{
891    my $self = shift ;
892
893    return *$self->{UnCompSize}->get32bit() ;
894}
895
896sub eof
897{
898    my $self = shift ;
899
900    return *$self->{Closed} ;
901}
902
903
904sub 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
943sub binmode
944{
945    1;
946#    my $self     = shift ;
947#    return defined *$self->{FH}
948#            ? binmode *$self->{FH}
949#            : 1 ;
950}
951
952sub fileno
953{
954    my $self     = shift ;
955    return defined *$self->{FH}
956            ? *$self->{FH}->fileno()
957            : undef ;
958}
959
960sub opened
961{
962    my $self     = shift ;
963    return ! *$self->{Closed} ;
964}
965
966sub autoflush
967{
968    my $self     = shift ;
969    return defined *$self->{FH}
970            ? *$self->{FH}->autoflush(@_)
971            : undef ;
972}
973
974sub input_line_number
975{
976    return undef ;
977}
978
979
980sub _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
10071;
1008
1009__END__
1010
1011=head1 NAME
1012
1013IO::Compress::Base - Base Class for IO::Compress modules
1014
1015=head1 SYNOPSIS
1016
1017    use IO::Compress::Base ;
1018
1019=head1 DESCRIPTION
1020
1021This module is not intended for direct use in application code. Its sole
1022purpose is to be sub-classed by IO::Compress modules.
1023
1024=head1 SEE ALSO
1025
1026L<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
1028L<IO::Compress::FAQ|IO::Compress::FAQ>
1029
1030L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
1031L<Archive::Tar|Archive::Tar>,
1032L<IO::Zlib|IO::Zlib>
1033
1034=head1 AUTHOR
1035
1036This module was written by Paul Marquess, F<pmqs@cpan.org>.
1037
1038=head1 MODIFICATION HISTORY
1039
1040See the Changes file.
1041
1042=head1 COPYRIGHT AND LICENSE
1043
1044Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
1045
1046This program is free software; you can redistribute it and/or
1047modify it under the same terms as Perl itself.
1048
1049