ext/Compress/IO/Base/lib/IO/Compress/Base.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
  23 $VERSION = '2.000_12';
  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
 551 sub filterUncompressed
 552 {
 553 }
 554
 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
 603     $self->filterUncompressed($buffer);
 604
 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
 704     #my $status = *$self->{Compress}->reset() ;
 705     my $status = $self->reset() ;
 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
 716 sub reset
 717 {
 718     my $self = shift ;
 719     return *$self->{Compress}->reset() ;
 720 }
 721
 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
 984 =head1 AUTHOR
 985
 986 This module was written by Paul Marquess, F<pmqs@cpan.org>.
 987
 988
 989
 990 =head1 MODIFICATION HISTORY
 991
 992 See the Changes file.
 993
 994 =head1 COPYRIGHT AND LICENSE
 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