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