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 / Uncompress / Base.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  32.9 KB  |  1,424 lines
  1.  
  2. package IO::Uncompress::Base ;
  3.  
  4. use strict ;
  5. use warnings;
  6. use bytes;
  7.  
  8. our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS);
  9. @ISA    = qw(Exporter IO::File);
  10.  
  11.  
  12. $VERSION = '2.008';
  13.  
  14. use constant G_EOF => 0 ;
  15. use constant G_ERR => -1 ;
  16.  
  17. use IO::Compress::Base::Common 2.008 ;
  18. #use Parse::Parameters ;
  19.  
  20. use IO::File ;
  21. use Symbol;
  22. use Scalar::Util qw(readonly);
  23. use List::Util qw(min);
  24. use Carp ;
  25.  
  26. %EXPORT_TAGS = ( );
  27. push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
  28. #Exporter::export_ok_tags('all') ;
  29.  
  30.  
  31. sub smartRead
  32. {
  33.     my $self = $_[0];
  34.     my $out = $_[1];
  35.     my $size = $_[2];
  36.     $$out = "" ;
  37.  
  38.     my $offset = 0 ;
  39.  
  40.  
  41.     if (defined *$self->{InputLength}) {
  42.         return 0
  43.             if *$self->{InputLengthRemaining} <= 0 ;
  44.         $size = min($size, *$self->{InputLengthRemaining});
  45.     }
  46.  
  47.     if ( length *$self->{Prime} ) {
  48.         #$$out = substr(*$self->{Prime}, 0, $size, '') ;
  49.         $$out = substr(*$self->{Prime}, 0, $size) ;
  50.         substr(*$self->{Prime}, 0, $size) =  '' ;
  51.         if (length $$out == $size) {
  52.             *$self->{InputLengthRemaining} -= length $$out
  53.                 if defined *$self->{InputLength};
  54.  
  55.             return length $$out ;
  56.         }
  57.         $offset = length $$out ;
  58.     }
  59.  
  60.     my $get_size = $size - $offset ;
  61.  
  62.     #if ( defined *$self->{InputLength} ) {
  63.     #    $get_size = min($get_size, *$self->{InputLengthRemaining});
  64.     #}
  65.  
  66.     if (defined *$self->{FH})
  67.       { *$self->{FH}->read($$out, $get_size, $offset) }
  68.     elsif (defined *$self->{InputEvent}) {
  69.         my $got = 1 ;
  70.         while (length $$out < $size) {
  71.             last 
  72.                 if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0;
  73.         }
  74.  
  75.         if (length $$out > $size ) {
  76.             #*$self->{Prime} = substr($$out, $size, length($$out), '');
  77.             *$self->{Prime} = substr($$out, $size, length($$out));
  78.             substr($$out, $size, length($$out)) =  '';
  79.         }
  80.  
  81.        *$self->{EventEof} = 1 if $got <= 0 ;
  82.     }
  83.     else {
  84.        no warnings 'uninitialized';
  85.        my $buf = *$self->{Buffer} ;
  86.        $$buf = '' unless defined $$buf ;
  87.        #$$out = '' unless defined $$out ;
  88.        substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size);
  89.        if (*$self->{ConsumeInput})
  90.          { substr($$buf, 0, $get_size) = '' }
  91.        else  
  92.          { *$self->{BufferOffset} += length($$out) - $offset }
  93.     }
  94.  
  95.     *$self->{InputLengthRemaining} -= length($$out) #- $offset 
  96.         if defined *$self->{InputLength};
  97.         
  98.     $self->saveStatus(length $$out < 0 ? STATUS_ERROR : STATUS_OK) ;
  99.  
  100.     return length $$out;
  101. }
  102.  
  103. sub pushBack
  104. {
  105.     my $self = shift ;
  106.  
  107.     return if ! defined $_[0] || length $_[0] == 0 ;
  108.  
  109.     if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
  110.         *$self->{Prime} = $_[0] . *$self->{Prime} ;
  111.         *$self->{InputLengthRemaining} += length($_[0]);
  112.     }
  113.     else {
  114.         my $len = length $_[0];
  115.  
  116.         if($len > *$self->{BufferOffset}) {
  117.             *$self->{Prime} = substr($_[0], 0, $len - *$self->{BufferOffset}) . *$self->{Prime} ;
  118.             *$self->{InputLengthRemaining} = *$self->{InputLength};
  119.             *$self->{BufferOffset} = 0
  120.         }
  121.         else {
  122.             *$self->{InputLengthRemaining} += length($_[0]);
  123.             *$self->{BufferOffset} -= length($_[0]) ;
  124.         }
  125.     }
  126. }
  127.  
  128. sub smartSeek
  129. {
  130.     my $self   = shift ;
  131.     my $offset = shift ;
  132.     my $truncate = shift;
  133.     #print "smartSeek to $offset\n";
  134.  
  135.     # TODO -- need to take prime into account
  136.     if (defined *$self->{FH})
  137.       { *$self->{FH}->seek($offset, SEEK_SET) }
  138.     else {
  139.         *$self->{BufferOffset} = $offset ;
  140.         substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = ''
  141.             if $truncate;
  142.         return 1;
  143.     }
  144. }
  145.  
  146. sub smartWrite
  147. {
  148.     my $self   = shift ;
  149.     my $out_data = shift ;
  150.  
  151.     if (defined *$self->{FH}) {
  152.         # flush needed for 5.8.0 
  153.         defined *$self->{FH}->write($out_data, length $out_data) &&
  154.         defined *$self->{FH}->flush() ;
  155.     }
  156.     else {
  157.        my $buf = *$self->{Buffer} ;
  158.        substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ;
  159.        *$self->{BufferOffset} += length($out_data) ;
  160.        return 1;
  161.     }
  162. }
  163.  
  164. sub smartReadExact
  165. {
  166.     return $_[0]->smartRead($_[1], $_[2]) == $_[2];
  167. }
  168.  
  169. sub smartEof
  170. {
  171.     my ($self) = $_[0];
  172.     local $.; 
  173.  
  174.     return 0 if length *$self->{Prime} || *$self->{PushMode};
  175.  
  176.     if (defined *$self->{FH})
  177.      { *$self->{FH}->eof() }
  178.     elsif (defined *$self->{InputEvent})
  179.      { *$self->{EventEof} }
  180.     else 
  181.      { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) }
  182. }
  183.  
  184. sub clearError
  185. {
  186.     my $self   = shift ;
  187.  
  188.     *$self->{ErrorNo}  =  0 ;
  189.     ${ *$self->{Error} } = '' ;
  190. }
  191.  
  192. sub saveStatus
  193. {
  194.     my $self   = shift ;
  195.     my $errno = shift() + 0 ;
  196.     #return $errno unless $errno || ! defined *$self->{ErrorNo};
  197.     #return $errno unless $errno ;
  198.  
  199.     *$self->{ErrorNo}  = $errno;
  200.     ${ *$self->{Error} } = '' ;
  201.  
  202.     return *$self->{ErrorNo} ;
  203. }
  204.  
  205.  
  206. sub saveErrorString
  207. {
  208.     my $self   = shift ;
  209.     my $retval = shift ;
  210.  
  211.     #return $retval if ${ *$self->{Error} };
  212.  
  213.     ${ *$self->{Error} } = shift ;
  214.     *$self->{ErrorNo} = shift() + 0 if @_ ;
  215.  
  216.     #warn "saveErrorString: " . ${ *$self->{Error} } . " " . *$self->{Error} . "\n" ;
  217.     return $retval;
  218. }
  219.  
  220. sub croakError
  221. {
  222.     my $self   = shift ;
  223.     $self->saveErrorString(0, $_[0]);
  224.     croak $_[0];
  225. }
  226.  
  227.  
  228. sub closeError
  229. {
  230.     my $self = shift ;
  231.     my $retval = shift ;
  232.  
  233.     my $errno = *$self->{ErrorNo};
  234.     my $error = ${ *$self->{Error} };
  235.  
  236.     $self->close();
  237.  
  238.     *$self->{ErrorNo} = $errno ;
  239.     ${ *$self->{Error} } = $error ;
  240.  
  241.     return $retval;
  242. }
  243.  
  244. sub error
  245. {
  246.     my $self   = shift ;
  247.     return ${ *$self->{Error} } ;
  248. }
  249.  
  250. sub errorNo
  251. {
  252.     my $self   = shift ;
  253.     return *$self->{ErrorNo};
  254. }
  255.  
  256. sub HeaderError
  257. {
  258.     my ($self) = shift;
  259.     return $self->saveErrorString(undef, "Header Error: $_[0]", STATUS_ERROR);
  260. }
  261.  
  262. sub TrailerError
  263. {
  264.     my ($self) = shift;
  265.     return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", STATUS_ERROR);
  266. }
  267.  
  268. sub TruncatedHeader
  269. {
  270.     my ($self) = shift;
  271.     return $self->HeaderError("Truncated in $_[0] Section");
  272. }
  273.  
  274. sub TruncatedTrailer
  275. {
  276.     my ($self) = shift;
  277.     return $self->TrailerError("Truncated in $_[0] Section");
  278. }
  279.  
  280. sub postCheckParams
  281. {
  282.     return 1;
  283. }
  284.  
  285. sub checkParams
  286. {
  287.     my $self = shift ;
  288.     my $class = shift ;
  289.  
  290.     my $got = shift || IO::Compress::Base::Parameters::new();
  291.     
  292.     my $Valid = {
  293.                     'BlockSize'     => [1, 1, Parse_unsigned, 16 * 1024],
  294.                     'AutoClose'     => [1, 1, Parse_boolean,  0],
  295.                     'Strict'        => [1, 1, Parse_boolean,  0],
  296.                     'Append'        => [1, 1, Parse_boolean,  0],
  297.                     'Prime'         => [1, 1, Parse_any,      undef],
  298.                     'MultiStream'   => [1, 1, Parse_boolean,  0],
  299.                     'Transparent'   => [1, 1, Parse_any,      1],
  300.                     'Scan'          => [1, 1, Parse_boolean,  0],
  301.                     'InputLength'   => [1, 1, Parse_unsigned, undef],
  302.                     'BinModeOut'    => [1, 1, Parse_boolean,  0],
  303.                     #'Encode'        => [1, 1, Parse_any,       undef],
  304.  
  305.                    #'ConsumeInput'  => [1, 1, Parse_boolean,  0],
  306.  
  307.                     $self->getExtraParams(),
  308.  
  309.                     #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0,
  310.                     # ContinueAfterEof
  311.                 } ;
  312.  
  313.     $Valid->{TrailingData} = [1, 1, Parse_writable_scalar, undef]
  314.         if  *$self->{OneShot} ;
  315.         
  316.     $got->parse($Valid, @_ ) 
  317.         or $self->croakError("${class}: $got->{Error}")  ;
  318.  
  319.     $self->postCheckParams($got) 
  320.         or $self->croakError("${class}: " . $self->error())  ;
  321.  
  322.     return $got;
  323. }
  324.  
  325. sub _create
  326. {
  327.     my $obj = shift;
  328.     my $got = shift;
  329.     my $append_mode = shift ;
  330.  
  331.     my $class = ref $obj;
  332.     $obj->croakError("$class: Missing Input parameter")
  333.         if ! @_ && ! $got ;
  334.  
  335.     my $inValue = shift ;
  336.  
  337.     *$obj->{OneShot}           = 0 ;
  338.  
  339.     if (! $got)
  340.     {
  341.         $got = $obj->checkParams($class, undef, @_)
  342.             or return undef ;
  343.     }
  344.  
  345.     my $inType  = whatIsInput($inValue, 1);
  346.  
  347.     $obj->ckInputParam($class, $inValue, 1) 
  348.         or return undef ;
  349.  
  350.     *$obj->{InNew} = 1;
  351.  
  352.     $obj->ckParams($got)
  353.         or $obj->croakError("${class}: " . *$obj->{Error});
  354.  
  355.     if ($inType eq 'buffer' || $inType eq 'code') {
  356.         *$obj->{Buffer} = $inValue ;        
  357.         *$obj->{InputEvent} = $inValue 
  358.            if $inType eq 'code' ;
  359.     }
  360.     else {
  361.         if ($inType eq 'handle') {
  362.             *$obj->{FH} = $inValue ;
  363.             *$obj->{Handle} = 1 ;
  364.  
  365.             # Need to rewind for Scan
  366.             *$obj->{FH}->seek(0, SEEK_SET) 
  367.                 if $got->value('Scan');
  368.         }  
  369.         else {    
  370.             my $mode = '<';
  371.             $mode = '+<' if $got->value('Scan');
  372.             *$obj->{StdIO} = ($inValue eq '-');
  373.             *$obj->{FH} = new IO::File "$mode $inValue"
  374.                 or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ;
  375.         }
  376.         
  377.         *$obj->{LineNo} = $. = 0;
  378.         setBinModeInput(*$obj->{FH}) ;
  379.  
  380.         my $buff = "" ;
  381.         *$obj->{Buffer} = \$buff ;
  382.     }
  383.  
  384.     if ($got->parsed('Encode')) { 
  385.         my $want_encoding = $got->value('Encode');
  386.         *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding);
  387.     }
  388.  
  389.  
  390.     *$obj->{InputLength}       = $got->parsed('InputLength') 
  391.                                     ? $got->value('InputLength')
  392.                                     : undef ;
  393.     *$obj->{InputLengthRemaining} = $got->value('InputLength');
  394.     *$obj->{BufferOffset}      = 0 ;
  395.     *$obj->{AutoClose}         = $got->value('AutoClose');
  396.     *$obj->{Strict}            = $got->value('Strict');
  397.     *$obj->{BlockSize}         = $got->value('BlockSize');
  398.     *$obj->{Append}            = $got->value('Append');
  399.     *$obj->{AppendOutput}      = $append_mode || $got->value('Append');
  400.     *$obj->{ConsumeInput}      = $got->value('ConsumeInput');
  401.     *$obj->{Transparent}       = $got->value('Transparent');
  402.     *$obj->{MultiStream}       = $got->value('MultiStream');
  403.  
  404.     # TODO - move these two into RawDeflate
  405.     *$obj->{Scan}              = $got->value('Scan');
  406.     *$obj->{ParseExtra}        = $got->value('ParseExtra') 
  407.                                   || $got->value('Strict')  ;
  408.     *$obj->{Type}              = '';
  409.     *$obj->{Prime}             = $got->value('Prime') || '' ;
  410.     *$obj->{Pending}           = '';
  411.     *$obj->{Plain}             = 0;
  412.     *$obj->{PlainBytesRead}    = 0;
  413.     *$obj->{InflatedBytesRead} = 0;
  414.     *$obj->{UnCompSize}        = new U64;
  415.     *$obj->{CompSize}          = new U64;
  416.     *$obj->{TotalInflatedBytesRead} = 0;
  417.     *$obj->{NewStream}         = 0 ;
  418.     *$obj->{EventEof}          = 0 ;
  419.     *$obj->{ClassName}         = $class ;
  420.     *$obj->{Params}            = $got ;
  421.  
  422.     if (*$obj->{ConsumeInput}) {
  423.         *$obj->{InNew} = 0;
  424.         *$obj->{Closed} = 0;
  425.         return $obj
  426.     }
  427.  
  428.     my $status = $obj->mkUncomp($class, $got);
  429.  
  430.     return undef
  431.         unless defined $status;
  432.  
  433.     if ( !  $status) {
  434.         return undef 
  435.             unless *$obj->{Transparent};
  436.  
  437.         $obj->clearError();
  438.         *$obj->{Type} = 'plain';
  439.         *$obj->{Plain} = 1;
  440.         #$status = $obj->mkIdentityUncomp($class, $got);
  441.         $obj->pushBack(*$obj->{HeaderPending})  ;
  442.     }
  443.  
  444.     push @{ *$obj->{InfoList} }, *$obj->{Info} ;
  445.  
  446.     $obj->saveStatus(STATUS_OK) ;
  447.     *$obj->{InNew} = 0;
  448.     *$obj->{Closed} = 0;
  449.  
  450.     return $obj;
  451. }
  452.  
  453. sub ckInputParam
  454. {
  455.     my $self = shift ;
  456.     my $from = shift ;
  457.     my $inType = whatIsInput($_[0], $_[1]);
  458.  
  459.     $self->croakError("$from: input parameter not a filename, filehandle, array ref or scalar ref")
  460.         if ! $inType ;
  461.  
  462.     if ($inType  eq 'filename' )
  463.     {
  464.         $self->croakError("$from: input filename is undef or null string")
  465.             if ! defined $_[0] || $_[0] eq ''  ;
  466.  
  467.         if ($_[0] ne '-' && ! -e $_[0] )
  468.         {
  469.             return $self->saveErrorString(undef, 
  470.                             "input file '$_[0]' does not exist", STATUS_ERROR);
  471.         }
  472.     }
  473.  
  474.     return 1;
  475. }
  476.  
  477.  
  478. sub _inf
  479. {
  480.     my $obj = shift ;
  481.  
  482.     my $class = (caller)[0] ;
  483.     my $name = (caller(1))[3] ;
  484.  
  485.     $obj->croakError("$name: expected at least 1 parameters\n")
  486.         unless @_ >= 1 ;
  487.  
  488.     my $input = shift ;
  489.     my $haveOut = @_ ;
  490.     my $output = shift ;
  491.  
  492.  
  493.     my $x = new Validator($class, *$obj->{Error}, $name, $input, $output)
  494.         or return undef ;
  495.     
  496.     push @_, $output if $haveOut && $x->{Hash};
  497.  
  498.     *$obj->{OneShot} = 1 ;
  499.     
  500.     my $got = $obj->checkParams($name, undef, @_)
  501.         or return undef ;
  502.  
  503.     if ($got->parsed('TrailingData'))
  504.     {
  505.         *$obj->{TrailingData} = $got->value('TrailingData');
  506.     }
  507.  
  508.     *$obj->{MultiStream} = $got->value('MultiStream');
  509.     $got->value('MultiStream', 0);
  510.  
  511.     $x->{Got} = $got ;
  512.  
  513. #    if ($x->{Hash})
  514. #    {
  515. #        while (my($k, $v) = each %$input)
  516. #        {
  517. #            $v = \$input->{$k} 
  518. #                unless defined $v ;
  519. #
  520. #            $obj->_singleTarget($x, $k, $v, @_)
  521. #                or return undef ;
  522. #        }
  523. #
  524. #        return keys %$input ;
  525. #    }
  526.     
  527.     if ($x->{GlobMap})
  528.     {
  529.         $x->{oneInput} = 1 ;
  530.         foreach my $pair (@{ $x->{Pairs} })
  531.         {
  532.             my ($from, $to) = @$pair ;
  533.             $obj->_singleTarget($x, $from, $to, @_)
  534.                 or return undef ;
  535.         }
  536.  
  537.         return scalar @{ $x->{Pairs} } ;
  538.     }
  539.  
  540.     if (! $x->{oneOutput} )
  541.     {
  542.         my $inFile = ($x->{inType} eq 'filenames' 
  543.                         || $x->{inType} eq 'filename');
  544.  
  545.         $x->{inType} = $inFile ? 'filename' : 'buffer';
  546.         
  547.         foreach my $in ($x->{oneInput} ? $input : @$input)
  548.         {
  549.             my $out ;
  550.             $x->{oneInput} = 1 ;
  551.  
  552.             $obj->_singleTarget($x, $in, $output, @_)
  553.                 or return undef ;
  554.         }
  555.  
  556.         return 1 ;
  557.     }
  558.  
  559.     # finally the 1 to 1 and n to 1
  560.     return $obj->_singleTarget($x, $input, $output, @_);
  561.  
  562.     croak "should not be here" ;
  563. }
  564.  
  565. sub retErr
  566. {
  567.     my $x = shift ;
  568.     my $string = shift ;
  569.  
  570.     ${ $x->{Error} } = $string ;
  571.  
  572.     return undef ;
  573. }
  574.  
  575. sub _singleTarget
  576. {
  577.     my $self      = shift ;
  578.     my $x         = shift ;
  579.     my $input     = shift;
  580.     my $output    = shift;
  581.     
  582.     my $buff = '';
  583.     $x->{buff} = \$buff ;
  584.  
  585.     my $fh ;
  586.     if ($x->{outType} eq 'filename') {
  587.         my $mode = '>' ;
  588.         $mode = '>>'
  589.             if $x->{Got}->value('Append') ;
  590.         $x->{fh} = new IO::File "$mode $output" 
  591.             or return retErr($x, "cannot open file '$output': $!") ;
  592.         binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
  593.  
  594.     }
  595.  
  596.     elsif ($x->{outType} eq 'handle') {
  597.         $x->{fh} = $output;
  598.         binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
  599.         if ($x->{Got}->value('Append')) {
  600.                 seek($x->{fh}, 0, SEEK_END)
  601.                     or return retErr($x, "Cannot seek to end of output filehandle: $!") ;
  602.             }
  603.     }
  604.  
  605.     
  606.     elsif ($x->{outType} eq 'buffer' )
  607.     {
  608.         $$output = '' 
  609.             unless $x->{Got}->value('Append');
  610.         $x->{buff} = $output ;
  611.     }
  612.  
  613.     if ($x->{oneInput})
  614.     {
  615.         defined $self->_rd2($x, $input, $output)
  616.             or return undef; 
  617.     }
  618.     else
  619.     {
  620.         for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
  621.         {
  622.             defined $self->_rd2($x, $element, $output) 
  623.                 or return undef ;
  624.         }
  625.     }
  626.  
  627.  
  628.     if ( ($x->{outType} eq 'filename' && $output ne '-') || 
  629.          ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) {
  630.         $x->{fh}->close() 
  631.             or return retErr($x, $!); 
  632.         delete $x->{fh};
  633.     }
  634.  
  635.     return 1 ;
  636. }
  637.  
  638. sub _rd2
  639. {
  640.     my $self      = shift ;
  641.     my $x         = shift ;
  642.     my $input     = shift;
  643.     my $output    = shift;
  644.         
  645.     my $z = createSelfTiedObject($x->{Class}, *$self->{Error});
  646.     
  647.     $z->_create($x->{Got}, 1, $input, @_)
  648.         or return undef ;
  649.  
  650.     my $status ;
  651.     my $fh = $x->{fh};
  652.     
  653.     while (1) {
  654.  
  655.         while (($status = $z->read($x->{buff})) > 0) {
  656.             if ($fh) {
  657.                 print $fh ${ $x->{buff} }
  658.                     or return $z->saveErrorString(undef, "Error writing to output file: $!", $!);
  659.                 ${ $x->{buff} } = '' ;
  660.             }
  661.         }
  662.  
  663.         if (! $x->{oneOutput} ) {
  664.             my $ot = $x->{outType} ;
  665.  
  666.             if ($ot eq 'array') 
  667.               { push @$output, $x->{buff} }
  668.             elsif ($ot eq 'hash') 
  669.               { $output->{$input} = $x->{buff} }
  670.  
  671.             my $buff = '';
  672.             $x->{buff} = \$buff;
  673.         }
  674.  
  675.         last 
  676.             unless *$self->{MultiStream};
  677.  
  678.         $status = $z->nextStream();
  679.  
  680.         last 
  681.             unless $status == 1 ;
  682.     }
  683.  
  684.     return $z->closeError(undef)
  685.         if $status < 0 ;
  686.  
  687.     ${ *$self->{TrailingData} } = $z->trailingData()
  688.         if defined *$self->{TrailingData} ;
  689.  
  690.     $z->close() 
  691.         or return undef ;
  692.  
  693.     return 1 ;
  694. }
  695.  
  696. sub TIEHANDLE
  697. {
  698.     return $_[0] if ref($_[0]);
  699.     die "OOPS\n" ;
  700.  
  701. }
  702.   
  703. sub UNTIE
  704. {
  705.     my $self = shift ;
  706. }
  707.  
  708.  
  709. sub getHeaderInfo
  710. {
  711.     my $self = shift ;
  712.     wantarray ? @{ *$self->{InfoList} } : *$self->{Info};
  713. }
  714.  
  715. sub readBlock
  716. {
  717.     my $self = shift ;
  718.     my $buff = shift ;
  719.     my $size = shift ;
  720.  
  721.     if (defined *$self->{CompressedInputLength}) {
  722.         if (*$self->{CompressedInputLengthRemaining} == 0) {
  723.             delete *$self->{CompressedInputLength};
  724.             *$self->{CompressedInputLengthDone} = 1;
  725.             return STATUS_OK ;
  726.         }
  727.         $size = min($size, *$self->{CompressedInputLengthRemaining} );
  728.         *$self->{CompressedInputLengthRemaining} -= $size ;
  729.     }
  730.     
  731.     my $status = $self->smartRead($buff, $size) ;
  732.     return $self->saveErrorString(STATUS_ERROR, "Error Reading Data")
  733.         if $status < 0  ;
  734.  
  735.     if ($status == 0 ) {
  736.         *$self->{Closed} = 1 ;
  737.         *$self->{EndStream} = 1 ;
  738.         return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR);
  739.     }
  740.  
  741.     return STATUS_OK;
  742. }
  743.  
  744. sub postBlockChk
  745. {
  746.     return STATUS_OK;
  747. }
  748.  
  749. sub _raw_read
  750. {
  751.     # return codes
  752.     # >0 - ok, number of bytes read
  753.     # =0 - ok, eof
  754.     # <0 - not ok
  755.     
  756.     my $self = shift ;
  757.  
  758.     return G_EOF if *$self->{Closed} ;
  759.     #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
  760.     return G_EOF if *$self->{EndStream} ;
  761.  
  762.     my $buffer = shift ;
  763.     my $scan_mode = shift ;
  764.  
  765.     if (*$self->{Plain}) {
  766.         my $tmp_buff ;
  767.         my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ;
  768.         
  769.         return $self->saveErrorString(G_ERR, "Error reading data: $!", $!) 
  770.                 if $len < 0 ;
  771.  
  772.         if ($len == 0 ) {
  773.             *$self->{EndStream} = 1 ;
  774.         }
  775.         else {
  776.             *$self->{PlainBytesRead} += $len ;
  777.             $$buffer .= $tmp_buff;
  778.         }
  779.  
  780.         return $len ;
  781.     }
  782.  
  783.     if (*$self->{NewStream}) {
  784.  
  785.         $self->gotoNextStream() > 0
  786.             or return G_ERR;
  787.  
  788.         # For the headers that actually uncompressed data, put the
  789.         # uncompressed data into the output buffer.
  790.         $$buffer .=  *$self->{Pending} ;
  791.         my $len = length  *$self->{Pending} ;
  792.         *$self->{Pending} = '';
  793.         return $len; 
  794.     }
  795.  
  796.     my $temp_buf = '';
  797.     my $outSize = 0;
  798.     my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ;
  799.     return G_ERR
  800.         if $status == STATUS_ERROR  ;
  801.  
  802.     my $buf_len = 0;
  803.     if ($status == STATUS_OK) {
  804.         my $beforeC_len = length $temp_buf;
  805.         my $before_len = defined $$buffer ? length $$buffer : 0 ;
  806.         $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer,
  807.                                     defined *$self->{CompressedInputLengthDone} ||
  808.                                                 $self->smartEof(), $outSize);
  809.  
  810.         return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo})
  811.             if $self->saveStatus($status) == STATUS_ERROR;
  812.  
  813.         $self->postBlockChk($buffer, $before_len) == STATUS_OK
  814.             or return G_ERR;
  815.  
  816.         $buf_len = length($$buffer) - $before_len;
  817.     
  818.         *$self->{CompSize}->add($beforeC_len - length $temp_buf) ;
  819.  
  820.         *$self->{InflatedBytesRead} += $buf_len ;
  821.         *$self->{TotalInflatedBytesRead} += $buf_len ;
  822.         *$self->{UnCompSize}->add($buf_len) ;
  823.  
  824.         $self->filterUncompressed($buffer);
  825.  
  826.         if (*$self->{Encoding}) {
  827.             $$buffer = *$self->{Encoding}->decode($$buffer);
  828.         }
  829.     }
  830.  
  831.     if ($status == STATUS_ENDSTREAM) {
  832.  
  833.         *$self->{EndStream} = 1 ;
  834.         $self->pushBack($temp_buf)  ;
  835.         $temp_buf = '';
  836.  
  837.         my $trailer;
  838.         my $trailer_size = *$self->{Info}{TrailerLength} ;
  839.         my $got = 0;
  840.         if (*$self->{Info}{TrailerLength})
  841.         {
  842.             $got = $self->smartRead(\$trailer, $trailer_size) ;
  843.         }
  844.  
  845.         if ($got == $trailer_size) {
  846.             $self->chkTrailer($trailer) == STATUS_OK
  847.                 or return G_ERR;
  848.         }
  849.         else {
  850.             return $self->TrailerError("trailer truncated. Expected " . 
  851.                                       "$trailer_size bytes, got $got")
  852.                 if *$self->{Strict};
  853.             $self->pushBack($trailer)  ;
  854.         }
  855.  
  856.         # TODO - if want to file file pointer, do it here
  857.  
  858.         if (! $self->smartEof()) {
  859.             *$self->{NewStream} = 1 ;
  860.  
  861.             if (*$self->{MultiStream}) {
  862.                 *$self->{EndStream} = 0 ;
  863.                 return $buf_len ;
  864.             }
  865.         }
  866.  
  867.     }
  868.     
  869.  
  870.     # return the number of uncompressed bytes read
  871.     return $buf_len ;
  872. }
  873.  
  874. sub reset
  875. {
  876.     my $self = shift ;
  877.  
  878.     return *$self->{Uncomp}->reset();
  879. }
  880.  
  881. sub filterUncompressed
  882. {
  883. }
  884.  
  885. #sub isEndStream
  886. #{
  887. #    my $self = shift ;
  888. #    return *$self->{NewStream} ||
  889. #           *$self->{EndStream} ;
  890. #}
  891.  
  892. sub nextStream
  893. {
  894.     my $self = shift ;
  895.  
  896.     my $status = $self->gotoNextStream();
  897.     $status == 1
  898.         or return $status ;
  899.  
  900.     *$self->{TotalInflatedBytesRead} = 0 ;
  901.     *$self->{LineNo} = $. = 0;
  902.  
  903.     return 1;
  904. }
  905.  
  906. sub gotoNextStream
  907. {
  908.     my $self = shift ;
  909.  
  910.     if (! *$self->{NewStream}) {
  911.         my $status = 1;
  912.         my $buffer ;
  913.  
  914.         # TODO - make this more efficient if know the offset for the end of
  915.         # the stream and seekable
  916.         $status = $self->read($buffer) 
  917.             while $status > 0 ;
  918.  
  919.         return $status
  920.             if $status < 0;
  921.     }
  922.  
  923.     *$self->{NewStream} = 0 ;
  924.     *$self->{EndStream} = 0 ;
  925.     $self->reset();
  926.     *$self->{UnCompSize}->reset();
  927.     *$self->{CompSize}->reset();
  928.  
  929.     my $magic = $self->ckMagic();
  930.     #*$self->{EndStream} = 0 ;
  931.  
  932.     if ( ! $magic) {
  933.         if (! *$self->{Transparent} )
  934.         {
  935.             *$self->{EndStream} = 1 ;
  936.             return 0;
  937.         }
  938.  
  939.         $self->clearError();
  940.         *$self->{Type} = 'plain';
  941.         *$self->{Plain} = 1;
  942.         $self->pushBack(*$self->{HeaderPending})  ;
  943.     }
  944.     else
  945.     {
  946.         *$self->{Info} = $self->readHeader($magic);
  947.  
  948.         if ( ! defined *$self->{Info} ) {
  949.             *$self->{EndStream} = 1 ;
  950.             return -1;
  951.         }
  952.     }
  953.  
  954.     push @{ *$self->{InfoList} }, *$self->{Info} ;
  955.  
  956.     return 1; 
  957. }
  958.  
  959. sub streamCount
  960. {
  961.     my $self = shift ;
  962.     return 1 if ! defined *$self->{InfoList};
  963.     return scalar @{ *$self->{InfoList} }  ;
  964. }
  965.  
  966. sub read
  967. {
  968.     # return codes
  969.     # >0 - ok, number of bytes read
  970.     # =0 - ok, eof
  971.     # <0 - not ok
  972.     
  973.     my $self = shift ;
  974.  
  975.     return G_EOF if *$self->{Closed} ;
  976.  
  977.     my $buffer ;
  978.  
  979.     if (ref $_[0] ) {
  980.         $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
  981.             if readonly(${ $_[0] });
  982.  
  983.         $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" )
  984.             unless ref $_[0] eq 'SCALAR' ;
  985.         $buffer = $_[0] ;
  986.     }
  987.     else {
  988.         $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
  989.             if readonly($_[0]);
  990.  
  991.         $buffer = \$_[0] ;
  992.     }
  993.  
  994.     my $length = $_[1] ;
  995.     my $offset = $_[2] || 0;
  996.  
  997.     if (! *$self->{AppendOutput}) {
  998.         if (! $offset) {    
  999.             $$buffer = '' ;
  1000.         }
  1001.         else {
  1002.             if ($offset > length($$buffer)) {
  1003.                 $$buffer .= "\x00" x ($offset - length($$buffer));
  1004.             }
  1005.             else {
  1006.                 substr($$buffer, $offset) = '';
  1007.             }
  1008.         }
  1009.     }
  1010.  
  1011.     return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
  1012.  
  1013.     # the core read will return 0 if asked for 0 bytes
  1014.     return 0 if defined $length && $length == 0 ;
  1015.  
  1016.     $length = $length || 0;
  1017.  
  1018.     $self->croakError(*$self->{ClassName} . "::read: length parameter is negative")
  1019.         if $length < 0 ;
  1020.  
  1021.     # Short-circuit if this is a simple read, with no length
  1022.     # or offset specified.
  1023.     unless ( $length || $offset) {
  1024.         if (length *$self->{Pending}) {
  1025.             $$buffer .= *$self->{Pending} ;
  1026.             my $len = length *$self->{Pending};
  1027.             *$self->{Pending} = '' ;
  1028.             return $len ;
  1029.         }
  1030.         else {
  1031.             my $len = 0;
  1032.             $len = $self->_raw_read($buffer) 
  1033.                 while ! *$self->{EndStream} && $len == 0 ;
  1034.             return $len ;
  1035.         }
  1036.     }
  1037.  
  1038.     # Need to jump through more hoops - either length or offset 
  1039.     # or both are specified.
  1040.     my $out_buffer = *$self->{Pending} ;
  1041.  
  1042.  
  1043.     while (! *$self->{EndStream} && length($out_buffer) < $length)
  1044.     {
  1045.         my $buf_len = $self->_raw_read(\$out_buffer);
  1046.         return $buf_len 
  1047.             if $buf_len < 0 ;
  1048.     }
  1049.  
  1050.     $length = length $out_buffer 
  1051.         if length($out_buffer) < $length ;
  1052.  
  1053.     return 0 
  1054.         if $length == 0 ;
  1055.  
  1056.     $$buffer = '' 
  1057.         if ! defined $$buffer;
  1058.  
  1059.     $offset = length $$buffer
  1060.         if *$self->{AppendOutput} ;
  1061.  
  1062.     *$self->{Pending} = $out_buffer;
  1063.     $out_buffer = \*$self->{Pending} ;
  1064.  
  1065.     #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ;
  1066.     substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ;
  1067.     substr($$out_buffer, 0, $length) =  '' ;
  1068.  
  1069.     return $length ;
  1070. }
  1071.  
  1072. sub _getline
  1073. {
  1074.     my $self = shift ;
  1075.  
  1076.     # Slurp Mode
  1077.     if ( ! defined $/ ) {
  1078.         my $data ;
  1079.         1 while $self->read($data) > 0 ;
  1080.         return \$data ;
  1081.     }
  1082.  
  1083.     # Record Mode
  1084.     if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) {
  1085.         my $reclen = ${$/} ;
  1086.         my $data ;
  1087.         $self->read($data, $reclen) ;
  1088.         return \$data ;
  1089.     }
  1090.  
  1091.     # Paragraph Mode
  1092.     if ( ! length $/ ) {
  1093.         my $paragraph ;    
  1094.         while ($self->read($paragraph) > 0 ) {
  1095.             if ($paragraph =~ s/^(.*?\n\n+)//s) {
  1096.                 *$self->{Pending}  = $paragraph ;
  1097.                 my $par = $1 ;
  1098.                 return \$par ;
  1099.             }
  1100.         }
  1101.         return \$paragraph;
  1102.     }
  1103.  
  1104.     # $/ isn't empty, or a reference, so it's Line Mode.
  1105.     {
  1106.         my $line ;    
  1107.         my $offset;
  1108.         my $p = \*$self->{Pending}  ;
  1109.  
  1110.         if (length(*$self->{Pending}) && 
  1111.                     ($offset = index(*$self->{Pending}, $/)) >=0) {
  1112.             my $l = substr(*$self->{Pending}, 0, $offset + length $/ );
  1113.             substr(*$self->{Pending}, 0, $offset + length $/) = '';    
  1114.             return \$l;
  1115.         }
  1116.  
  1117.         while ($self->read($line) > 0 ) {
  1118.             my $offset = index($line, $/);
  1119.             if ($offset >= 0) {
  1120.                 my $l = substr($line, 0, $offset + length $/ );
  1121.                 substr($line, 0, $offset + length $/) = '';    
  1122.                 $$p = $line;
  1123.                 return \$l;
  1124.             }
  1125.         }
  1126.  
  1127.         return \$line;
  1128.     }
  1129. }
  1130.  
  1131. sub getline
  1132. {
  1133.     my $self = shift;
  1134.     my $current_append = *$self->{AppendOutput} ;
  1135.     *$self->{AppendOutput} = 1;
  1136.     my $lineref = $self->_getline();
  1137.     $. = ++ *$self->{LineNo} if defined $$lineref ;
  1138.     *$self->{AppendOutput} = $current_append;
  1139.     return $$lineref ;
  1140. }
  1141.  
  1142. sub getlines
  1143. {
  1144.     my $self = shift;
  1145.     $self->croakError(*$self->{ClassName} . 
  1146.             "::getlines: called in scalar context\n") unless wantarray;
  1147.     my($line, @lines);
  1148.     push(@lines, $line) 
  1149.         while defined($line = $self->getline);
  1150.     return @lines;
  1151. }
  1152.  
  1153. sub READLINE
  1154. {
  1155.     goto &getlines if wantarray;
  1156.     goto &getline;
  1157. }
  1158.  
  1159. sub getc
  1160. {
  1161.     my $self = shift;
  1162.     my $buf;
  1163.     return $buf if $self->read($buf, 1);
  1164.     return undef;
  1165. }
  1166.  
  1167. sub ungetc
  1168. {
  1169.     my $self = shift;
  1170.     *$self->{Pending} = ""  unless defined *$self->{Pending} ;    
  1171.     *$self->{Pending} = $_[0] . *$self->{Pending} ;    
  1172. }
  1173.  
  1174.  
  1175. sub trailingData
  1176. {
  1177.     my $self = shift ;
  1178.  
  1179.     if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
  1180.         return *$self->{Prime} ;
  1181.     }
  1182.     else {
  1183.         my $buf = *$self->{Buffer} ;
  1184.         my $offset = *$self->{BufferOffset} ;
  1185.         return substr($$buf, $offset) ;
  1186.     }
  1187. }
  1188.  
  1189.  
  1190. sub eof
  1191. {
  1192.     my $self = shift ;
  1193.  
  1194.     return (*$self->{Closed} ||
  1195.               (!length *$self->{Pending} 
  1196.                 && ( $self->smartEof() || *$self->{EndStream}))) ;
  1197. }
  1198.  
  1199. sub tell
  1200. {
  1201.     my $self = shift ;
  1202.  
  1203.     my $in ;
  1204.     if (*$self->{Plain}) {
  1205.         $in = *$self->{PlainBytesRead} ;
  1206.     }
  1207.     else {
  1208.         $in = *$self->{TotalInflatedBytesRead} ;
  1209.     }
  1210.  
  1211.     my $pending = length *$self->{Pending} ;
  1212.  
  1213.     return 0 if $pending > $in ;
  1214.     return $in - $pending ;
  1215. }
  1216.  
  1217. sub close
  1218. {
  1219.     # todo - what to do if close is called before the end of the gzip file
  1220.     #        do we remember any trailing data?
  1221.     my $self = shift ;
  1222.  
  1223.     return 1 if *$self->{Closed} ;
  1224.  
  1225.     untie *$self 
  1226.         if $] >= 5.008 ;
  1227.  
  1228.     my $status = 1 ;
  1229.  
  1230.     if (defined *$self->{FH}) {
  1231.         if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
  1232.         #if ( *$self->{AutoClose}) {
  1233.             local $.; 
  1234.             $! = 0 ;
  1235.             $status = *$self->{FH}->close();
  1236.             return $self->saveErrorString(0, $!, $!)
  1237.                 if !*$self->{InNew} && $self->saveStatus($!) != 0 ;
  1238.         }
  1239.         delete *$self->{FH} ;
  1240.         $! = 0 ;
  1241.     }
  1242.     *$self->{Closed} = 1 ;
  1243.  
  1244.     return 1;
  1245. }
  1246.  
  1247. sub DESTROY
  1248. {
  1249.     my $self = shift ;
  1250.     $self->close() ;
  1251. }
  1252.  
  1253. sub seek
  1254. {
  1255.     my $self     = shift ;
  1256.     my $position = shift;
  1257.     my $whence   = shift ;
  1258.  
  1259.     my $here = $self->tell() ;
  1260.     my $target = 0 ;
  1261.  
  1262.  
  1263.     if ($whence == SEEK_SET) {
  1264.         $target = $position ;
  1265.     }
  1266.     elsif ($whence == SEEK_CUR) {
  1267.         $target = $here + $position ;
  1268.     }
  1269.     elsif ($whence == SEEK_END) {
  1270.         $target = $position ;
  1271.         $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ;
  1272.     }
  1273.     else {
  1274.         $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter");
  1275.     }
  1276.  
  1277.     # short circuit if seeking to current offset
  1278.     return 1 if $target == $here ;    
  1279.  
  1280.     # Outlaw any attempt to seek backwards
  1281.     $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards")
  1282.         if $target < $here ;
  1283.  
  1284.     # Walk the file to the new offset
  1285.     my $offset = $target - $here ;
  1286.  
  1287.     my $got;
  1288.     while (($got = $self->read(my $buffer, min($offset, *$self->{BlockSize})) ) > 0)
  1289.     {
  1290.         $offset -= $got;
  1291.         last if $offset == 0 ;
  1292.     }
  1293.  
  1294.     return $offset == 0 ? 1 : 0 ;
  1295. }
  1296.  
  1297. sub fileno
  1298. {
  1299.     my $self = shift ;
  1300.     return defined *$self->{FH} 
  1301.            ? fileno *$self->{FH} 
  1302.            : undef ;
  1303. }
  1304.  
  1305. sub binmode
  1306. {
  1307.     1;
  1308. #    my $self     = shift ;
  1309. #    return defined *$self->{FH} 
  1310. #            ? binmode *$self->{FH} 
  1311. #            : 1 ;
  1312. }
  1313.  
  1314. sub opened
  1315. {
  1316.     my $self     = shift ;
  1317.     return ! *$self->{Closed} ;
  1318. }
  1319.  
  1320. sub autoflush
  1321. {
  1322.     my $self     = shift ;
  1323.     return defined *$self->{FH} 
  1324.             ? *$self->{FH}->autoflush(@_) 
  1325.             : undef ;
  1326. }
  1327.  
  1328. sub input_line_number
  1329. {
  1330.     my $self = shift ;
  1331.     my $last = *$self->{LineNo};
  1332.     $. = *$self->{LineNo} = $_[1] if @_ ;
  1333.     return $last;
  1334. }
  1335.  
  1336.  
  1337. *BINMODE  = \&binmode;
  1338. *SEEK     = \&seek; 
  1339. *READ     = \&read;
  1340. *sysread  = \&read;
  1341. *TELL     = \&tell;
  1342. *EOF      = \&eof;
  1343.  
  1344. *FILENO   = \&fileno;
  1345. *CLOSE    = \&close;
  1346.  
  1347. sub _notAvailable
  1348. {
  1349.     my $name = shift ;
  1350.     #return sub { croak "$name Not Available" ; } ;
  1351.     return sub { croak "$name Not Available: File opened only for intput" ; } ;
  1352. }
  1353.  
  1354.  
  1355. *print    = _notAvailable('print');
  1356. *PRINT    = _notAvailable('print');
  1357. *printf   = _notAvailable('printf');
  1358. *PRINTF   = _notAvailable('printf');
  1359. *write    = _notAvailable('write');
  1360. *WRITE    = _notAvailable('write');
  1361.  
  1362. #*sysread  = \&read;
  1363. #*syswrite = \&_notAvailable;
  1364.  
  1365.  
  1366.  
  1367. package IO::Uncompress::Base ;
  1368.  
  1369.  
  1370. 1 ;
  1371. __END__
  1372.  
  1373. =head1 NAME
  1374.  
  1375.  
  1376. IO::Uncompress::Base - Base Class for IO::Uncompress modules 
  1377.  
  1378.  
  1379. =head1 SYNOPSIS
  1380.  
  1381.     use IO::Uncompress::Base ;
  1382.  
  1383. =head1 DESCRIPTION
  1384.  
  1385.  
  1386. This module is not intended for direct use in application code. Its sole
  1387. purpose if to to be sub-classed by IO::Unompress modules.
  1388.  
  1389.  
  1390.  
  1391.  
  1392. =head1 SEE ALSO
  1393.  
  1394. 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>
  1395.  
  1396. L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
  1397.  
  1398. L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
  1399. L<Archive::Tar|Archive::Tar>,
  1400. L<IO::Zlib|IO::Zlib>
  1401.  
  1402.  
  1403.  
  1404.  
  1405.  
  1406. =head1 AUTHOR
  1407.  
  1408. This module was written by Paul Marquess, F<pmqs@cpan.org>. 
  1409.  
  1410.  
  1411.  
  1412. =head1 MODIFICATION HISTORY
  1413.  
  1414. See the Changes file.
  1415.  
  1416. =head1 COPYRIGHT AND LICENSE
  1417.  
  1418. Copyright (c) 2005-2007 Paul Marquess. All rights reserved.
  1419.  
  1420. This program is free software; you can redistribute it and/or
  1421. modify it under the same terms as Perl itself.
  1422.  
  1423.  
  1424.