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