home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / IO / Compress / Base / Common.pm
Encoding:
Perl POD Document  |  2008-09-03  |  20.8 KB  |  941 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.015';
  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 IO::Compress::Base::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 IO::Compress::Base::Validator::saveErrorString
  324. {
  325.     my $self   = shift ;
  326.     ${ $self->{Error} } = shift ;
  327.     return undef;
  328.     
  329. }
  330.  
  331. sub IO::Compress::Base::Validator::croakError
  332. {
  333.     my $self   = shift ;
  334.     $self->saveErrorString($_[0]);
  335.     croak $_[0];
  336. }
  337.  
  338.  
  339.  
  340. sub IO::Compress::Base::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 IO::Compress::Base::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 IO::Compress::Base::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.     
  489.     return $_[1]
  490.         if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters");
  491.     
  492.     my $p = new IO::Compress::Base::Parameters() ;            
  493.     $p->parse(@_)
  494.         or croak "$sub: $p->{Error}" ;
  495.  
  496.     return $p;
  497. }
  498.  
  499. #package IO::Compress::Base::Parameters;
  500.  
  501. use strict;
  502. use warnings;
  503. use Carp;
  504.  
  505. sub IO::Compress::Base::Parameters::new
  506. {
  507.     my $class = shift ;
  508.  
  509.     my $obj = { Error => '',
  510.                 Got   => {},
  511.               } ;
  512.  
  513.     #return bless $obj, ref($class) || $class || __PACKAGE__ ;
  514.     return bless $obj, 'IO::Compress::Base::Parameters' ;
  515. }
  516.  
  517. sub IO::Compress::Base::Parameters::setError
  518. {
  519.     my $self = shift ;
  520.     my $error = shift ;
  521.     my $retval = @_ ? shift : undef ;
  522.  
  523.     $self->{Error} = $error ;
  524.     return $retval;
  525. }
  526.           
  527. #sub getError
  528. #{
  529. #    my $self = shift ;
  530. #    return $self->{Error} ;
  531. #}
  532.           
  533. sub IO::Compress::Base::Parameters::parse
  534. {
  535.     my $self = shift ;
  536.  
  537.     my $default = shift ;
  538.  
  539.     my $got = $self->{Got} ;
  540.     my $firstTime = keys %{ $got } == 0 ;
  541.     my $other;
  542.  
  543.     my (@Bad) ;
  544.     my @entered = () ;
  545.  
  546.     # Allow the options to be passed as a hash reference or
  547.     # as the complete hash.
  548.     if (@_ == 0) {
  549.         @entered = () ;
  550.     }
  551.     elsif (@_ == 1) {
  552.         my $href = $_[0] ;
  553.     
  554.         return $self->setError("Expected even number of parameters, got 1")
  555.             if ! defined $href or ! ref $href or ref $href ne "HASH" ;
  556.  
  557.         foreach my $key (keys %$href) {
  558.             push @entered, $key ;
  559.             push @entered, \$href->{$key} ;
  560.         }
  561.     }
  562.     else {
  563.         my $count = @_;
  564.         return $self->setError("Expected even number of parameters, got $count")
  565.             if $count % 2 != 0 ;
  566.         
  567.         for my $i (0.. $count / 2 - 1) {
  568.             if ($_[2 * $i] eq '__xxx__') {
  569.                 $other = $_[2 * $i + 1] ;
  570.             }
  571.             else {
  572.                 push @entered, $_[2 * $i] ;
  573.                 push @entered, \$_[2 * $i + 1] ;
  574.             }
  575.         }
  576.     }
  577.  
  578.  
  579.     while (my ($key, $v) = each %$default)
  580.     {
  581.         croak "need 4 params [@$v]"
  582.             if @$v != 4 ;
  583.  
  584.         my ($first_only, $sticky, $type, $value) = @$v ;
  585.         my $x ;
  586.         $self->_checkType($key, \$value, $type, 0, \$x) 
  587.             or return undef ;
  588.  
  589.         $key = lc $key;
  590.  
  591.         if ($firstTime || ! $sticky) {
  592.             $x = [ $x ]
  593.                 if $type & Parse_multiple;
  594.  
  595.             $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
  596.         }
  597.  
  598.         $got->{$key}[OFF_PARSED] = 0 ;
  599.     }
  600.  
  601.     my %parsed = ();
  602.     
  603.     if ($other) 
  604.     {
  605.         for my $key (keys %$default)  
  606.         {
  607.             my $canonkey = lc $key;
  608.             if ($other->parsed($canonkey))
  609.             {
  610.                 my $value = $other->value($canonkey);
  611. #print "SET '$canonkey' to $value [$$value]\n";
  612.                 ++ $parsed{$canonkey};
  613.                 $got->{$canonkey}[OFF_PARSED]  = 1;
  614.                 $got->{$canonkey}[OFF_DEFAULT] = $value;
  615.                 $got->{$canonkey}[OFF_FIXED]   = $value;
  616.             }
  617.         }
  618.     }
  619.     
  620.     for my $i (0.. @entered / 2 - 1) {
  621.         my $key = $entered[2* $i] ;
  622.         my $value = $entered[2* $i+1] ;
  623.  
  624.         #print "Key [$key] Value [$value]" ;
  625.         #print defined $$value ? "[$$value]\n" : "[undef]\n";
  626.  
  627.         $key =~ s/^-// ;
  628.         my $canonkey = lc $key;
  629.  
  630.         if ($got->{$canonkey} && ($firstTime ||
  631.                                   ! $got->{$canonkey}[OFF_FIRST_ONLY]  ))
  632.         {
  633.             my $type = $got->{$canonkey}[OFF_TYPE] ;
  634.             my $parsed = $parsed{$canonkey};
  635.             ++ $parsed{$canonkey};
  636.  
  637.             return $self->setError("Muliple instances of '$key' found") 
  638.                 if $parsed && $type & Parse_multiple == 0 ;
  639.  
  640.             my $s ;
  641.             $self->_checkType($key, $value, $type, 1, \$s)
  642.                 or return undef ;
  643.  
  644.             $value = $$value ;
  645.             if ($type & Parse_multiple) {
  646.                 $got->{$canonkey}[OFF_PARSED] = 1;
  647.                 push @{ $got->{$canonkey}[OFF_FIXED] }, $s ;
  648.             }
  649.             else {
  650.                 $got->{$canonkey} = [1, $type, $value, $s] ;
  651.             }
  652.         }
  653.         else
  654.           { push (@Bad, $key) }
  655.     }
  656.  
  657.     if (@Bad) {
  658.         my ($bad) = join(", ", @Bad) ;
  659.         return $self->setError("unknown key value(s) @Bad") ;
  660.     }
  661.  
  662.     return 1;
  663. }
  664.  
  665. sub IO::Compress::Base::Parameters::_checkType
  666. {
  667.     my $self = shift ;
  668.  
  669.     my $key   = shift ;
  670.     my $value = shift ;
  671.     my $type  = shift ;
  672.     my $validate  = shift ;
  673.     my $output  = shift;
  674.  
  675.     #local $Carp::CarpLevel = $level ;
  676.     #print "PARSE $type $key $value $validate $sub\n" ;
  677.  
  678.     if ($type & Parse_writable_scalar)
  679.     {
  680.         return $self->setError("Parameter '$key' not writable")
  681.             if $validate &&  readonly $$value ;
  682.  
  683.         if (ref $$value) 
  684.         {
  685.             return $self->setError("Parameter '$key' not a scalar reference")
  686.                 if $validate &&  ref $$value ne 'SCALAR' ;
  687.  
  688.             $$output = $$value ;
  689.         }
  690.         else  
  691.         {
  692.             return $self->setError("Parameter '$key' not a scalar")
  693.                 if $validate &&  ref $value ne 'SCALAR' ;
  694.  
  695.             $$output = $value ;
  696.         }
  697.  
  698.         return 1;
  699.     }
  700.  
  701. #    if ($type & Parse_store_ref)
  702. #    {
  703. #        #$value = $$value
  704. #        #    if ref ${ $value } ;
  705. #
  706. #        $$output = $value ;
  707. #        return 1;
  708. #    }
  709.  
  710.     $value = $$value ;
  711.  
  712.     if ($type & Parse_any)
  713.     {
  714.         $$output = $value ;
  715.         return 1;
  716.     }
  717.     elsif ($type & Parse_unsigned)
  718.     {
  719.         return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
  720.             if $validate && ! defined $value ;
  721.         return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
  722.             if $validate && $value !~ /^\d+$/;
  723.  
  724.         $$output = defined $value ? $value : 0 ;    
  725.         return 1;
  726.     }
  727.     elsif ($type & Parse_signed)
  728.     {
  729.         return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
  730.             if $validate && ! defined $value ;
  731.         return $self->setError("Parameter '$key' must be a signed int, got '$value'")
  732.             if $validate && $value !~ /^-?\d+$/;
  733.  
  734.         $$output = defined $value ? $value : 0 ;    
  735.         return 1 ;
  736.     }
  737.     elsif ($type & Parse_boolean)
  738.     {
  739.         return $self->setError("Parameter '$key' must be an int, got '$value'")
  740.             if $validate && defined $value && $value !~ /^\d*$/;
  741.         $$output =  defined $value ? $value != 0 : 0 ;    
  742.         return 1;
  743.     }
  744.     elsif ($type & Parse_string)
  745.     {
  746.         $$output = defined $value ? $value : "" ;    
  747.         return 1;
  748.     }
  749.  
  750.     $$output = $value ;
  751.     return 1;
  752. }
  753.  
  754.  
  755.  
  756. sub IO::Compress::Base::Parameters::parsed
  757. {
  758.     my $self = shift ;
  759.     my $name = shift ;
  760.  
  761.     return $self->{Got}{lc $name}[OFF_PARSED] ;
  762. }
  763.  
  764. sub IO::Compress::Base::Parameters::value
  765. {
  766.     my $self = shift ;
  767.     my $name = shift ;
  768.  
  769.     if (@_)
  770.     {
  771.         $self->{Got}{lc $name}[OFF_PARSED]  = 1;
  772.         $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
  773.         $self->{Got}{lc $name}[OFF_FIXED]   = $_[0] ;
  774.     }
  775.  
  776.     return $self->{Got}{lc $name}[OFF_FIXED] ;
  777. }
  778.  
  779. sub IO::Compress::Base::Parameters::valueOrDefault
  780. {
  781.     my $self = shift ;
  782.     my $name = shift ;
  783.     my $default = shift ;
  784.  
  785.     my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
  786.  
  787.     return $value if defined $value ;
  788.     return $default ;
  789. }
  790.  
  791. sub IO::Compress::Base::Parameters::wantValue
  792. {
  793.     my $self = shift ;
  794.     my $name = shift ;
  795.  
  796.     return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
  797.  
  798. }
  799.  
  800. sub IO::Compress::Base::Parameters::clone
  801. {
  802.     my $self = shift ;
  803.     my $obj = { };
  804.     my %got ;
  805.  
  806.     while (my ($k, $v) = each %{ $self->{Got} }) {
  807.         $got{$k} = [ @$v ];
  808.     }
  809.  
  810.     $obj->{Error} = $self->{Error};
  811.     $obj->{Got} = \%got ;
  812.  
  813.     return bless $obj, 'IO::Compress::Base::Parameters' ;
  814. }
  815.  
  816. package U64;
  817.  
  818. use constant MAX32 => 0xFFFFFFFF ;
  819. use constant LOW   => 0 ;
  820. use constant HIGH  => 1;
  821.  
  822. sub new
  823. {
  824.     my $class = shift ;
  825.  
  826.     my $high = 0 ;
  827.     my $low  = 0 ;
  828.  
  829.     if (@_ == 2) {
  830.         $high = shift ;
  831.         $low  = shift ;
  832.     }
  833.     elsif (@_ == 1) {
  834.         $low  = shift ;
  835.     }
  836.  
  837.     bless [$low, $high], $class;
  838. }
  839.  
  840. sub newUnpack_V64
  841. {
  842.     my $string = shift;
  843.  
  844.     my ($low, $hi) = unpack "V V", $string ;
  845.     bless [ $low, $hi ], "U64";
  846. }
  847.  
  848. sub newUnpack_V32
  849. {
  850.     my $string = shift;
  851.  
  852.     my $low = unpack "V", $string ;
  853.     bless [ $low, 0 ], "U64";
  854. }
  855.  
  856. sub reset
  857. {
  858.     my $self = shift;
  859.     $self->[HIGH] = $self->[LOW] = 0;
  860. }
  861.  
  862. sub clone
  863. {
  864.     my $self = shift;
  865.     bless [ @$self ], ref $self ;
  866. }
  867.  
  868. sub getHigh
  869. {
  870.     my $self = shift;
  871.     return $self->[HIGH];
  872. }
  873.  
  874. sub getLow
  875. {
  876.     my $self = shift;
  877.     return $self->[LOW];
  878. }
  879.  
  880. sub get32bit
  881. {
  882.     my $self = shift;
  883.     return $self->[LOW];
  884. }
  885.  
  886. sub add
  887. {
  888.     my $self = shift;
  889.     my $value = shift;
  890.  
  891.     if (ref $value eq 'U64') {
  892.         $self->[HIGH] += $value->[HIGH] ;
  893.         $value = $value->[LOW];
  894.     }
  895.      
  896.     my $available = MAX32 - $self->[LOW] ;
  897.  
  898.     if ($value > $available) {
  899.        ++ $self->[HIGH] ;
  900.        $self->[LOW] = $value - $available - 1;
  901.     }
  902.     else {
  903.        $self->[LOW] += $value ;
  904.     }
  905. }
  906.  
  907. sub equal
  908. {
  909.     my $self = shift;
  910.     my $other = shift;
  911.  
  912.     return $self->[LOW]  == $other->[LOW] &&
  913.            $self->[HIGH] == $other->[HIGH] ;
  914. }
  915.  
  916. sub getPacked_V64
  917. {
  918.     my $self = shift;
  919.  
  920.     return pack "V V", @$self ;
  921. }
  922.  
  923. sub getPacked_V32
  924. {
  925.     my $self = shift;
  926.  
  927.     return pack "V", $self->[LOW] ;
  928. }
  929.  
  930. sub pack_V64
  931. {
  932.     my $low  = shift;
  933.  
  934.     return pack "V V", $low, 0;
  935. }
  936.  
  937.  
  938. package IO::Compress::Base::Common;
  939.  
  940. 1;
  941.