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 / Common.pm
Encoding:
Perl POD Document  |  2009-06-26  |  19.9 KB  |  912 lines
  1. package IO::Compress::Base::Common;
  2.  
  3. use strict ;
  4. use warnings;
  5. use bytes;
  6.  
  7. use Carp;
  8. use Scalar::Util qw(blessed readonly);
  9. use File::GlobMapper;
  10.  
  11. require Exporter;
  12. our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
  13. @ISA = qw(Exporter);
  14. $VERSION = '2.008';
  15.  
  16. @EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput 
  17.               isaFileGlobString cleanFileGlobString oneTarget
  18.               setBinModeInput setBinModeOutput
  19.               ckInOutParams 
  20.               createSelfTiedObject
  21.               getEncoding
  22.  
  23.               WANT_CODE
  24.               WANT_EXT
  25.               WANT_UNDEF
  26.               WANT_HASH
  27.  
  28.               STATUS_OK
  29.               STATUS_ENDSTREAM
  30.               STATUS_EOF
  31.               STATUS_ERROR
  32.           );  
  33.  
  34. %EXPORT_TAGS = ( Status => [qw( STATUS_OK
  35.                                  STATUS_ENDSTREAM
  36.                                  STATUS_EOF
  37.                                  STATUS_ERROR
  38.                            )]);
  39.  
  40.                        
  41. use constant STATUS_OK        => 0;
  42. use constant STATUS_ENDSTREAM => 1;
  43. use constant STATUS_EOF       => 2;
  44. use constant STATUS_ERROR     => -1;
  45.           
  46. sub hasEncode()
  47. {
  48.     if (! defined $HAS_ENCODE) {
  49.         eval
  50.         {
  51.             require Encode;
  52.             Encode->import();
  53.         };
  54.  
  55.         $HAS_ENCODE = $@ ? 0 : 1 ;
  56.     }
  57.  
  58.     return $HAS_ENCODE;
  59. }
  60.  
  61. sub getEncoding($$$)
  62. {
  63.     my $obj = shift;
  64.     my $class = shift ;
  65.     my $want_encoding = shift ;
  66.  
  67.     $obj->croakError("$class: Encode module needed to use -Encode")
  68.         if ! hasEncode();
  69.  
  70.     my $encoding = Encode::find_encoding($want_encoding);
  71.  
  72.     $obj->croakError("$class: Encoding '$want_encoding' is not available")
  73.        if ! $encoding;
  74.  
  75.     return $encoding;
  76. }
  77.  
  78. our ($needBinmode);
  79. $needBinmode = ($^O eq 'MSWin32' || 
  80.                     ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
  81.                     ? 1 : 1 ;
  82.  
  83. sub setBinModeInput($)
  84. {
  85.     my $handle = shift ;
  86.  
  87.     binmode $handle 
  88.         if  $needBinmode;
  89. }
  90.  
  91. sub setBinModeOutput($)
  92. {
  93.     my $handle = shift ;
  94.  
  95.     binmode $handle 
  96.         if  $needBinmode;
  97. }
  98.  
  99. sub isaFilehandle($)
  100. {
  101.     use utf8; # Pragma needed to keep Perl 5.6.0 happy
  102.     return (defined $_[0] and 
  103.              (UNIVERSAL::isa($_[0],'GLOB') or 
  104.               UNIVERSAL::isa($_[0],'IO::Handle') or
  105.               UNIVERSAL::isa(\$_[0],'GLOB')) 
  106.           )
  107. }
  108.  
  109. sub isaFilename($)
  110. {
  111.     return (defined $_[0] and 
  112.            ! ref $_[0]    and 
  113.            UNIVERSAL::isa(\$_[0], 'SCALAR'));
  114. }
  115.  
  116. sub isaFileGlobString
  117. {
  118.     return defined $_[0] && $_[0] =~ /^<.*>$/;
  119. }
  120.  
  121. sub cleanFileGlobString
  122. {
  123.     my $string = shift ;
  124.  
  125.     $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
  126.  
  127.     return $string;
  128. }
  129.  
  130. use constant WANT_CODE  => 1 ;
  131. use constant WANT_EXT   => 2 ;
  132. use constant WANT_UNDEF => 4 ;
  133. #use constant WANT_HASH  => 8 ;
  134. use constant WANT_HASH  => 0 ;
  135.  
  136. sub whatIsInput($;$)
  137. {
  138.     my $got = whatIs(@_);
  139.     
  140.     if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
  141.     {
  142.         #use IO::File;
  143.         $got = 'handle';
  144.         $_[0] = *STDIN;
  145.         #$_[0] = new IO::File("<-");
  146.     }
  147.  
  148.     return $got;
  149. }
  150.  
  151. sub whatIsOutput($;$)
  152. {
  153.     my $got = whatIs(@_);
  154.     
  155.     if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
  156.     {
  157.         $got = 'handle';
  158.         $_[0] = *STDOUT;
  159.         #$_[0] = new IO::File(">-");
  160.     }
  161.     
  162.     return $got;
  163. }
  164.  
  165. sub whatIs ($;$)
  166. {
  167.     return 'handle' if isaFilehandle($_[0]);
  168.  
  169.     my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
  170.     my $extended = defined $_[1] && $_[1] & WANT_EXT ;
  171.     my $undef    = defined $_[1] && $_[1] & WANT_UNDEF ;
  172.     my $hash     = defined $_[1] && $_[1] & WANT_HASH ;
  173.  
  174.     return 'undef'  if ! defined $_[0] && $undef ;
  175.  
  176.     if (ref $_[0]) {
  177.         return ''       if blessed($_[0]); # is an object
  178.         #return ''       if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
  179.         return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
  180.         return 'array'  if UNIVERSAL::isa($_[0], 'ARRAY')  && $extended ;
  181.         return 'hash'   if UNIVERSAL::isa($_[0], 'HASH')   && $hash ;
  182.         return 'code'   if UNIVERSAL::isa($_[0], 'CODE')   && $wantCode ;
  183.         return '';
  184.     }
  185.  
  186.     return 'fileglob' if $extended && isaFileGlobString($_[0]);
  187.     return 'filename';
  188. }
  189.  
  190. sub oneTarget
  191. {
  192.     return $_[0] =~ /^(code|handle|buffer|filename)$/;
  193. }
  194.  
  195. sub Validator::new
  196. {
  197.     my $class = shift ;
  198.  
  199.     my $Class = shift ;
  200.     my $error_ref = shift ;
  201.     my $reportClass = shift ;
  202.  
  203.     my %data = (Class       => $Class, 
  204.                 Error       => $error_ref,
  205.                 reportClass => $reportClass, 
  206.                ) ;
  207.  
  208.     my $obj = bless \%data, $class ;
  209.  
  210.     local $Carp::CarpLevel = 1;
  211.  
  212.     my $inType    = $data{inType}    = whatIsInput($_[0], WANT_EXT|WANT_HASH);
  213.     my $outType   = $data{outType}   = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
  214.  
  215.     my $oneInput  = $data{oneInput}  = oneTarget($inType);
  216.     my $oneOutput = $data{oneOutput} = oneTarget($outType);
  217.  
  218.     if (! $inType)
  219.     {
  220.         $obj->croakError("$reportClass: illegal input parameter") ;
  221.         #return undef ;
  222.     }    
  223.  
  224. #    if ($inType eq 'hash')
  225. #    {
  226. #        $obj->{Hash} = 1 ;
  227. #        $obj->{oneInput} = 1 ;
  228. #        return $obj->validateHash($_[0]);
  229. #    }
  230.  
  231.     if (! $outType)
  232.     {
  233.         $obj->croakError("$reportClass: illegal output parameter") ;
  234.         #return undef ;
  235.     }    
  236.  
  237.  
  238.     if ($inType ne 'fileglob' && $outType eq 'fileglob')
  239.     {
  240.         $obj->croakError("Need input fileglob for outout fileglob");
  241.     }    
  242.  
  243. #    if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
  244. #    {
  245. #        $obj->croakError("input must ne filename or fileglob when output is a hash");
  246. #    }    
  247.  
  248.     if ($inType eq 'fileglob' && $outType eq 'fileglob')
  249.     {
  250.         $data{GlobMap} = 1 ;
  251.         $data{inType} = $data{outType} = 'filename';
  252.         my $mapper = new File::GlobMapper($_[0], $_[1]);
  253.         if ( ! $mapper )
  254.         {
  255.             return $obj->saveErrorString($File::GlobMapper::Error) ;
  256.         }
  257.         $data{Pairs} = $mapper->getFileMap();
  258.  
  259.         return $obj;
  260.     }
  261.     
  262.     $obj->croakError("$reportClass: input and output $inType are identical")
  263.         if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
  264.  
  265.     if ($inType eq 'fileglob') # && $outType ne 'fileglob'
  266.     {
  267.         my $glob = cleanFileGlobString($_[0]);
  268.         my @inputs = glob($glob);
  269.  
  270.         if (@inputs == 0)
  271.         {
  272.             # TODO -- legal or die?
  273.             die "globmap matched zero file -- legal or die???" ;
  274.         }
  275.         elsif (@inputs == 1)
  276.         {
  277.             $obj->validateInputFilenames($inputs[0])
  278.                 or return undef;
  279.             $_[0] = $inputs[0]  ;
  280.             $data{inType} = 'filename' ;
  281.             $data{oneInput} = 1;
  282.         }
  283.         else
  284.         {
  285.             $obj->validateInputFilenames(@inputs)
  286.                 or return undef;
  287.             $_[0] = [ @inputs ] ;
  288.             $data{inType} = 'filenames' ;
  289.         }
  290.     }
  291.     elsif ($inType eq 'filename')
  292.     {
  293.         $obj->validateInputFilenames($_[0])
  294.             or return undef;
  295.     }
  296.     elsif ($inType eq 'array')
  297.     {
  298.         $data{inType} = 'filenames' ;
  299.         $obj->validateInputArray($_[0])
  300.             or return undef ;
  301.     }
  302.  
  303.     return $obj->saveErrorString("$reportClass: output buffer is read-only")
  304.         if $outType eq 'buffer' && readonly(${ $_[1] });
  305.  
  306.     if ($outType eq 'filename' )
  307.     {
  308.         $obj->croakError("$reportClass: output filename is undef or null string")
  309.             if ! defined $_[1] || $_[1] eq ''  ;
  310.  
  311.         if (-e $_[1])
  312.         {
  313.             if (-d _ )
  314.             {
  315.                 return $obj->saveErrorString("output file '$_[1]' is a directory");
  316.             }
  317.         }
  318.     }
  319.     
  320.     return $obj ;
  321. }
  322.  
  323. sub Validator::saveErrorString
  324. {
  325.     my $self   = shift ;
  326.     ${ $self->{Error} } = shift ;
  327.     return undef;
  328.     
  329. }
  330.  
  331. sub Validator::croakError
  332. {
  333.     my $self   = shift ;
  334.     $self->saveErrorString($_[0]);
  335.     croak $_[0];
  336. }
  337.  
  338.  
  339.  
  340. sub Validator::validateInputFilenames
  341. {
  342.     my $self = shift ;
  343.  
  344.     foreach my $filename (@_)
  345.     {
  346.         $self->croakError("$self->{reportClass}: input filename is undef or null string")
  347.             if ! defined $filename || $filename eq ''  ;
  348.  
  349.         next if $filename eq '-';
  350.  
  351.         if (! -e $filename )
  352.         {
  353.             return $self->saveErrorString("input file '$filename' does not exist");
  354.         }
  355.  
  356.         if (-d _ )
  357.         {
  358.             return $self->saveErrorString("input file '$filename' is a directory");
  359.         }
  360.  
  361.         if (! -r _ )
  362.         {
  363.             return $self->saveErrorString("cannot open file '$filename': $!");
  364.         }
  365.     }
  366.  
  367.     return 1 ;
  368. }
  369.  
  370. sub Validator::validateInputArray
  371. {
  372.     my $self = shift ;
  373.  
  374.     if ( @{ $_[0] } == 0 )
  375.     {
  376.         return $self->saveErrorString("empty array reference") ;
  377.     }    
  378.  
  379.     foreach my $element ( @{ $_[0] } )
  380.     {
  381.         my $inType  = whatIsInput($element);
  382.     
  383.         if (! $inType)
  384.         {
  385.             $self->croakError("unknown input parameter") ;
  386.         }    
  387.         elsif($inType eq 'filename')
  388.         {
  389.             $self->validateInputFilenames($element)
  390.                 or return undef ;
  391.         }
  392.         else
  393.         {
  394.             $self->croakError("not a filename") ;
  395.         }
  396.     }
  397.  
  398.     return 1 ;
  399. }
  400.  
  401. #sub Validator::validateHash
  402. #{
  403. #    my $self = shift ;
  404. #    my $href = shift ;
  405. #
  406. #    while (my($k, $v) = each %$href)
  407. #    {
  408. #        my $ktype = whatIsInput($k);
  409. #        my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
  410. #
  411. #        if ($ktype ne 'filename')
  412. #        {
  413. #            return $self->saveErrorString("hash key not filename") ;
  414. #        }    
  415. #
  416. #        my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
  417. #        if (! $valid{$vtype})
  418. #        {
  419. #            return $self->saveErrorString("hash value not ok") ;
  420. #        }    
  421. #    }
  422. #
  423. #    return $self ;
  424. #}
  425.  
  426. sub createSelfTiedObject
  427. {
  428.     my $class = shift || (caller)[0] ;
  429.     my $error_ref = shift ;
  430.  
  431.     my $obj = bless Symbol::gensym(), ref($class) || $class;
  432.     tie *$obj, $obj if $] >= 5.005;
  433.     *$obj->{Closed} = 1 ;
  434.     $$error_ref = '';
  435.     *$obj->{Error} = $error_ref ;
  436.     my $errno = 0 ;
  437.     *$obj->{ErrorNo} = \$errno ;
  438.  
  439.     return $obj;
  440. }
  441.  
  442.  
  443.  
  444. #package Parse::Parameters ;
  445. #
  446. #
  447. #require Exporter;
  448. #our ($VERSION, @ISA, @EXPORT);
  449. #$VERSION = '2.000_08';
  450. #@ISA = qw(Exporter);
  451.  
  452. $EXPORT_TAGS{Parse} = [qw( ParseParameters 
  453.                            Parse_any Parse_unsigned Parse_signed 
  454.                            Parse_boolean Parse_custom Parse_string
  455.                            Parse_multiple Parse_writable_scalar
  456.                          )
  457.                       ];              
  458.  
  459. push @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
  460.  
  461. use constant Parse_any      => 0x01;
  462. use constant Parse_unsigned => 0x02;
  463. use constant Parse_signed   => 0x04;
  464. use constant Parse_boolean  => 0x08;
  465. use constant Parse_string   => 0x10;
  466. use constant Parse_custom   => 0x12;
  467.  
  468. #use constant Parse_store_ref        => 0x100 ;
  469. use constant Parse_multiple         => 0x100 ;
  470. use constant Parse_writable         => 0x200 ;
  471. use constant Parse_writable_scalar  => 0x400 | Parse_writable ;
  472.  
  473. use constant OFF_PARSED     => 0 ;
  474. use constant OFF_TYPE       => 1 ;
  475. use constant OFF_DEFAULT    => 2 ;
  476. use constant OFF_FIXED      => 3 ;
  477. use constant OFF_FIRST_ONLY => 4 ;
  478. use constant OFF_STICKY     => 5 ;
  479.  
  480.  
  481.  
  482. sub ParseParameters
  483. {
  484.     my $level = shift || 0 ; 
  485.  
  486.     my $sub = (caller($level + 1))[3] ;
  487.     local $Carp::CarpLevel = 1 ;
  488.     my $p = new IO::Compress::Base::Parameters() ;
  489.     $p->parse(@_)
  490.         or croak "$sub: $p->{Error}" ;
  491.  
  492.     return $p;
  493. }
  494.  
  495. #package IO::Compress::Base::Parameters;
  496.  
  497. use strict;
  498. use warnings;
  499. use Carp;
  500.  
  501. sub IO::Compress::Base::Parameters::new
  502. {
  503.     my $class = shift ;
  504.  
  505.     my $obj = { Error => '',
  506.                 Got   => {},
  507.               } ;
  508.  
  509.     #return bless $obj, ref($class) || $class || __PACKAGE__ ;
  510.     return bless $obj, 'IO::Compress::Base::Parameters' ;
  511. }
  512.  
  513. sub IO::Compress::Base::Parameters::setError
  514. {
  515.     my $self = shift ;
  516.     my $error = shift ;
  517.     my $retval = @_ ? shift : undef ;
  518.  
  519.     $self->{Error} = $error ;
  520.     return $retval;
  521. }
  522.           
  523. #sub getError
  524. #{
  525. #    my $self = shift ;
  526. #    return $self->{Error} ;
  527. #}
  528.           
  529. sub IO::Compress::Base::Parameters::parse
  530. {
  531.     my $self = shift ;
  532.  
  533.     my $default = shift ;
  534.  
  535.     my $got = $self->{Got} ;
  536.     my $firstTime = keys %{ $got } == 0 ;
  537.  
  538.     my (@Bad) ;
  539.     my @entered = () ;
  540.  
  541.     # Allow the options to be passed as a hash reference or
  542.     # as the complete hash.
  543.     if (@_ == 0) {
  544.         @entered = () ;
  545.     }
  546.     elsif (@_ == 1) {
  547.         my $href = $_[0] ;    
  548.         return $self->setError("Expected even number of parameters, got 1")
  549.             if ! defined $href or ! ref $href or ref $href ne "HASH" ;
  550.  
  551.         foreach my $key (keys %$href) {
  552.             push @entered, $key ;
  553.             push @entered, \$href->{$key} ;
  554.         }
  555.     }
  556.     else {
  557.         my $count = @_;
  558.         return $self->setError("Expected even number of parameters, got $count")
  559.             if $count % 2 != 0 ;
  560.         
  561.         for my $i (0.. $count / 2 - 1) {
  562.             push @entered, $_[2* $i] ;
  563.             push @entered, \$_[2* $i+1] ;
  564.         }
  565.     }
  566.  
  567.  
  568.     while (my ($key, $v) = each %$default)
  569.     {
  570.         croak "need 4 params [@$v]"
  571.             if @$v != 4 ;
  572.  
  573.         my ($first_only, $sticky, $type, $value) = @$v ;
  574.         my $x ;
  575.         $self->_checkType($key, \$value, $type, 0, \$x) 
  576.             or return undef ;
  577.  
  578.         $key = lc $key;
  579.  
  580.         if ($firstTime || ! $sticky) {
  581.             $x = [ $x ]
  582.                 if $type & Parse_multiple;
  583.  
  584.             $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
  585.         }
  586.  
  587.         $got->{$key}[OFF_PARSED] = 0 ;
  588.     }
  589.  
  590.     my %parsed = ();
  591.     for my $i (0.. @entered / 2 - 1) {
  592.         my $key = $entered[2* $i] ;
  593.         my $value = $entered[2* $i+1] ;
  594.  
  595.         #print "Key [$key] Value [$value]" ;
  596.         #print defined $$value ? "[$$value]\n" : "[undef]\n";
  597.  
  598.         $key =~ s/^-// ;
  599.         my $canonkey = lc $key;
  600.  
  601.         if ($got->{$canonkey} && ($firstTime ||
  602.                                   ! $got->{$canonkey}[OFF_FIRST_ONLY]  ))
  603.         {
  604.             my $type = $got->{$canonkey}[OFF_TYPE] ;
  605.             my $parsed = $parsed{$canonkey};
  606.             ++ $parsed{$canonkey};
  607.  
  608.             return $self->setError("Muliple instances of '$key' found") 
  609.                 if $parsed && $type & Parse_multiple == 0 ;
  610.  
  611.             my $s ;
  612.             $self->_checkType($key, $value, $type, 1, \$s)
  613.                 or return undef ;
  614.  
  615.             $value = $$value ;
  616.             if ($type & Parse_multiple) {
  617.                 $got->{$canonkey}[OFF_PARSED] = 1;
  618.                 push @{ $got->{$canonkey}[OFF_FIXED] }, $s ;
  619.             }
  620.             else {
  621.                 $got->{$canonkey} = [1, $type, $value, $s] ;
  622.             }
  623.         }
  624.         else
  625.           { push (@Bad, $key) }
  626.     }
  627.  
  628.     if (@Bad) {
  629.         my ($bad) = join(", ", @Bad) ;
  630.         return $self->setError("unknown key value(s) @Bad") ;
  631.     }
  632.  
  633.     return 1;
  634. }
  635.  
  636. sub IO::Compress::Base::Parameters::_checkType
  637. {
  638.     my $self = shift ;
  639.  
  640.     my $key   = shift ;
  641.     my $value = shift ;
  642.     my $type  = shift ;
  643.     my $validate  = shift ;
  644.     my $output  = shift;
  645.  
  646.     #local $Carp::CarpLevel = $level ;
  647.     #print "PARSE $type $key $value $validate $sub\n" ;
  648.  
  649.     if ($type & Parse_writable_scalar)
  650.     {
  651.         return $self->setError("Parameter '$key' not writable")
  652.             if $validate &&  readonly $$value ;
  653.  
  654.         if (ref $$value) 
  655.         {
  656.             return $self->setError("Parameter '$key' not a scalar reference")
  657.                 if $validate &&  ref $$value ne 'SCALAR' ;
  658.  
  659.             $$output = $$value ;
  660.         }
  661.         else  
  662.         {
  663.             return $self->setError("Parameter '$key' not a scalar")
  664.                 if $validate &&  ref $value ne 'SCALAR' ;
  665.  
  666.             $$output = $value ;
  667.         }
  668.  
  669.         return 1;
  670.     }
  671.  
  672. #    if ($type & Parse_store_ref)
  673. #    {
  674. #        #$value = $$value
  675. #        #    if ref ${ $value } ;
  676. #
  677. #        $$output = $value ;
  678. #        return 1;
  679. #    }
  680.  
  681.     $value = $$value ;
  682.  
  683.     if ($type & Parse_any)
  684.     {
  685.         $$output = $value ;
  686.         return 1;
  687.     }
  688.     elsif ($type & Parse_unsigned)
  689.     {
  690.         return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
  691.             if $validate && ! defined $value ;
  692.         return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
  693.             if $validate && $value !~ /^\d+$/;
  694.  
  695.         $$output = defined $value ? $value : 0 ;    
  696.         return 1;
  697.     }
  698.     elsif ($type & Parse_signed)
  699.     {
  700.         return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
  701.             if $validate && ! defined $value ;
  702.         return $self->setError("Parameter '$key' must be a signed int, got '$value'")
  703.             if $validate && $value !~ /^-?\d+$/;
  704.  
  705.         $$output = defined $value ? $value : 0 ;    
  706.         return 1 ;
  707.     }
  708.     elsif ($type & Parse_boolean)
  709.     {
  710.         return $self->setError("Parameter '$key' must be an int, got '$value'")
  711.             if $validate && defined $value && $value !~ /^\d*$/;
  712.         $$output =  defined $value ? $value != 0 : 0 ;    
  713.         return 1;
  714.     }
  715.     elsif ($type & Parse_string)
  716.     {
  717.         $$output = defined $value ? $value : "" ;    
  718.         return 1;
  719.     }
  720.  
  721.     $$output = $value ;
  722.     return 1;
  723. }
  724.  
  725.  
  726.  
  727. sub IO::Compress::Base::Parameters::parsed
  728. {
  729.     my $self = shift ;
  730.     my $name = shift ;
  731.  
  732.     return $self->{Got}{lc $name}[OFF_PARSED] ;
  733. }
  734.  
  735. sub IO::Compress::Base::Parameters::value
  736. {
  737.     my $self = shift ;
  738.     my $name = shift ;
  739.  
  740.     if (@_)
  741.     {
  742.         $self->{Got}{lc $name}[OFF_PARSED]  = 1;
  743.         $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
  744.         $self->{Got}{lc $name}[OFF_FIXED]   = $_[0] ;
  745.     }
  746.  
  747.     return $self->{Got}{lc $name}[OFF_FIXED] ;
  748. }
  749.  
  750. sub IO::Compress::Base::Parameters::valueOrDefault
  751. {
  752.     my $self = shift ;
  753.     my $name = shift ;
  754.     my $default = shift ;
  755.  
  756.     my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
  757.  
  758.     return $value if defined $value ;
  759.     return $default ;
  760. }
  761.  
  762. sub IO::Compress::Base::Parameters::wantValue
  763. {
  764.     my $self = shift ;
  765.     my $name = shift ;
  766.  
  767.     return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
  768.  
  769. }
  770.  
  771. sub IO::Compress::Base::Parameters::clone
  772. {
  773.     my $self = shift ;
  774.     my $obj = { };
  775.     my %got ;
  776.  
  777.     while (my ($k, $v) = each %{ $self->{Got} }) {
  778.         $got{$k} = [ @$v ];
  779.     }
  780.  
  781.     $obj->{Error} = $self->{Error};
  782.     $obj->{Got} = \%got ;
  783.  
  784.     return bless $obj, 'IO::Compress::Base::Parameters' ;
  785. }
  786.  
  787. package U64;
  788.  
  789. use constant MAX32 => 0xFFFFFFFF ;
  790. use constant LOW   => 0 ;
  791. use constant HIGH  => 1;
  792.  
  793. sub new
  794. {
  795.     my $class = shift ;
  796.  
  797.     my $high = 0 ;
  798.     my $low  = 0 ;
  799.  
  800.     if (@_ == 2) {
  801.         $high = shift ;
  802.         $low  = shift ;
  803.     }
  804.     elsif (@_ == 1) {
  805.         $low  = shift ;
  806.     }
  807.  
  808.     bless [$low, $high], $class;
  809. }
  810.  
  811. sub newUnpack_V64
  812. {
  813.     my $string = shift;
  814.  
  815.     my ($low, $hi) = unpack "V V", $string ;
  816.     bless [ $low, $hi ], "U64";
  817. }
  818.  
  819. sub newUnpack_V32
  820. {
  821.     my $string = shift;
  822.  
  823.     my $low = unpack "V", $string ;
  824.     bless [ $low, 0 ], "U64";
  825. }
  826.  
  827. sub reset
  828. {
  829.     my $self = shift;
  830.     $self->[HIGH] = $self->[LOW] = 0;
  831. }
  832.  
  833. sub clone
  834. {
  835.     my $self = shift;
  836.     bless [ @$self ], ref $self ;
  837. }
  838.  
  839. sub getHigh
  840. {
  841.     my $self = shift;
  842.     return $self->[HIGH];
  843. }
  844.  
  845. sub getLow
  846. {
  847.     my $self = shift;
  848.     return $self->[LOW];
  849. }
  850.  
  851. sub get32bit
  852. {
  853.     my $self = shift;
  854.     return $self->[LOW];
  855. }
  856.  
  857. sub add
  858. {
  859.     my $self = shift;
  860.     my $value = shift;
  861.  
  862.     if (ref $value eq 'U64') {
  863.         $self->[HIGH] += $value->[HIGH] ;
  864.         $value = $value->[LOW];
  865.     }
  866.      
  867.     my $available = MAX32 - $self->[LOW] ;
  868.  
  869.     if ($value > $available) {
  870.        ++ $self->[HIGH] ;
  871.        $self->[LOW] = $value - $available - 1;
  872.     }
  873.     else {
  874.        $self->[LOW] += $value ;
  875.     }
  876. }
  877.  
  878. sub equal
  879. {
  880.     my $self = shift;
  881.     my $other = shift;
  882.  
  883.     return $self->[LOW]  == $other->[LOW] &&
  884.            $self->[HIGH] == $other->[HIGH] ;
  885. }
  886.  
  887. sub getPacked_V64
  888. {
  889.     my $self = shift;
  890.  
  891.     return pack "V V", @$self ;
  892. }
  893.  
  894. sub getPacked_V32
  895. {
  896.     my $self = shift;
  897.  
  898.     return pack "V", $self->[LOW] ;
  899. }
  900.  
  901. sub pack_V64
  902. {
  903.     my $low  = shift;
  904.  
  905.     return pack "V V", $low, 0;
  906. }
  907.  
  908.  
  909. package IO::Compress::Base::Common;
  910.  
  911. 1;
  912.