[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/i586-linux-thread-multi/IO/Compress/Base/ -> Common.pm (source)

   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;


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1