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