(tl)perl 5.18.2 for windows from siep

git-svn-id: svn://tug.org/texlive/trunk@33648 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 173 insertions, 185 deletions

diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm
index c6c38181ef8..cce097dd6dc 100644
--- a/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm
@@ -11,7 +11,7 @@ use File::GlobMapper;
 require Exporter;
 our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
 @ISA = qw(Exporter);
-$VERSION = '2.048';
+$VERSION = '2.060';
 
 @EXPORT = qw( isaFilehandle isaFilename isaScalar
               whatIsInput whatIsOutput 
@@ -19,8 +19,7 @@ $VERSION = '2.048';
               setBinModeInput setBinModeOutput
               ckInOutParams 
               createSelfTiedObject
-              getEncoding
-
+              
               isGeMax32
 
               MAX32
@@ -106,7 +105,7 @@ sub setBinModeOutput($)
 {
     my $handle = shift ;
 
-    binmode $handle 
+    binmode $handle
         if  $needBinmode;
 }
 
@@ -377,10 +376,10 @@ sub IO::Compress::Base::Validator::validateInputFilenames
             return $self->saveErrorString("input file '$filename' is a directory");
         }
 
-        if (! -r _ )
-        {
-            return $self->saveErrorString("cannot open file '$filename': $!");
-        }
+#        if (! -r _ )
+#        {
+#            return $self->saveErrorString("cannot open file '$filename': $!");
+#        }
     }
 
     return 1 ;
@@ -472,7 +471,7 @@ $EXPORT_TAGS{Parse} = [qw( ParseParameters
                            Parse_any Parse_unsigned Parse_signed 
                            Parse_boolean Parse_string
                            Parse_code
-                           Parse_multiple Parse_writable_scalar
+                           Parse_writable_scalar
                          )
                       ];              
 
@@ -486,7 +485,7 @@ use constant Parse_string   => 0x10;
 use constant Parse_code     => 0x20;
 
 #use constant Parse_store_ref        => 0x100 ;
-use constant Parse_multiple         => 0x100 ;
+#use constant Parse_multiple         => 0x100 ;
 use constant Parse_writable         => 0x200 ;
 use constant Parse_writable_scalar  => 0x400 | Parse_writable ;
 
@@ -494,10 +493,11 @@ use constant OFF_PARSED     => 0 ;
 use constant OFF_TYPE       => 1 ;
 use constant OFF_DEFAULT    => 2 ;
 use constant OFF_FIXED      => 3 ;
-use constant OFF_FIRST_ONLY => 4 ;
-use constant OFF_STICKY     => 5 ;
-
+#use constant OFF_FIRST_ONLY => 4 ;
+#use constant OFF_STICKY     => 5 ;
 
+use constant IxError => 0;
+use constant IxGot   => 1 ;
 
 sub ParseParameters
 {
@@ -511,27 +511,60 @@ sub ParseParameters
     
     my $p = new IO::Compress::Base::Parameters() ;            
     $p->parse(@_)
-        or croak "$sub: $p->{Error}" ;
+        or croak "$sub: $p->[IxError]" ;
 
     return $p;
 }
 
-#package IO::Compress::Base::Parameters;
 
 use strict;
 
 use warnings;
 use Carp;
 
+
+sub Init
+{
+    my $default = shift ;
+    my %got ;
+    
+    my $obj = IO::Compress::Base::Parameters::new();
+    while (my ($key, $v) = each %$default)
+    {
+        croak "need 2 params [@$v]"
+            if @$v != 2 ;
+
+        my ($type, $value) = @$v ;
+#        my ($first_only, $sticky, $type, $value) = @$v ;
+        my $sticky = 0;
+        my $x ;
+        $obj->_checkType($key, \$value, $type, 0, \$x) 
+            or return undef ;
+
+        $key = lc $key;
+
+#        if (! $sticky) {
+#            $x = []
+#                if $type & Parse_multiple;
+
+#            $got{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
+            $got{$key} = [0, $type, $value, $x] ;            
+#        }
+#
+#        $got{$key}[OFF_PARSED] = 0 ;
+    }
+    
+    return bless \%got, "IO::Compress::Base::Parameters::Defaults" ;
+}
+
 sub IO::Compress::Base::Parameters::new
 {
-    my $class = shift ;
+    #my $class = shift ;
 
-    my $obj = { Error => '',
-                Got   => {},
-              } ;
+    my $obj;
+    $obj->[IxError] = '';
+    $obj->[IxGot] = {} ;          
 
-    #return bless $obj, ref($class) || $class || __PACKAGE__ ;
     return bless $obj, 'IO::Compress::Base::Parameters' ;
 }
 
@@ -541,25 +574,24 @@ sub IO::Compress::Base::Parameters::setError
     my $error = shift ;
     my $retval = @_ ? shift : undef ;
 
-    $self->{Error} = $error ;
+
+    $self->[IxError] = $error ;
     return $retval;
 }
           
-#sub getError
-#{
-#    my $self = shift ;
-#    return $self->{Error} ;
-#}
+sub IO::Compress::Base::Parameters::getError
+{
+    my $self = shift ;
+    return $self->[IxError] ;
+}
           
 sub IO::Compress::Base::Parameters::parse
 {
     my $self = shift ;
-
     my $default = shift ;
 
-    my $got = $self->{Got} ;
+    my $got = $self->[IxGot] ;
     my $firstTime = keys %{ $got } == 0 ;
-    my $other;
 
     my (@Bad) ;
     my @entered = () ;
@@ -581,63 +613,35 @@ sub IO::Compress::Base::Parameters::parse
         }
     }
     else {
+       
         my $count = @_;
         return $self->setError("Expected even number of parameters, got $count")
             if $count % 2 != 0 ;
         
         for my $i (0.. $count / 2 - 1) {
-            if ($_[2 * $i] eq '__xxx__') {
-                $other = $_[2 * $i + 1] ;
-            }
-            else {
-                push @entered, $_[2 * $i] ;
-                push @entered, \$_[2 * $i + 1] ;
-            }
+            push @entered, $_[2 * $i] ;
+            push @entered, \$_[2 * $i + 1] ;
         }
     }
 
-
-    while (my ($key, $v) = each %$default)
-    {
-        croak "need 4 params [@$v]"
-            if @$v != 4 ;
-
-        my ($first_only, $sticky, $type, $value) = @$v ;
-        my $x ;
-        $self->_checkType($key, \$value, $type, 0, \$x) 
-            or return undef ;
-
-        $key = lc $key;
-
-        if ($firstTime || ! $sticky) {
-            $x = []
-                if $type & Parse_multiple;
-
-            $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
+        foreach my $key (keys %$default)
+        {
+    
+            my ($type, $value) = @{ $default->{$key} } ;
+  
+            if ($firstTime) {   
+                $got->{$key} = [0, $type, $value, $value] ;               
+            }
+            else
+            {
+                $got->{$key}[OFF_PARSED] = 0 ;      
+            }               
         }
 
-        $got->{$key}[OFF_PARSED] = 0 ;
-    }
 
     my %parsed = ();
     
-    if ($other) 
-    {
-        for my $key (keys %$default)  
-        {
-            my $canonkey = lc $key;
-            if ($other->parsed($canonkey))
-            {
-                my $value = $other->value($canonkey);
-#print "SET '$canonkey' to $value [$$value]\n";
-                ++ $parsed{$canonkey};
-                $got->{$canonkey}[OFF_PARSED]  = 1;
-                $got->{$canonkey}[OFF_DEFAULT] = $value;
-                $got->{$canonkey}[OFF_FIXED]   = $value;
-            }
-        }
-    }
-    
+   
     for my $i (0.. @entered / 2 - 1) {
         my $key = $entered[2* $i] ;
         my $value = $entered[2* $i+1] ;
@@ -648,28 +652,22 @@ sub IO::Compress::Base::Parameters::parse
         $key =~ s/^-// ;
         my $canonkey = lc $key;
  
-        if ($got->{$canonkey} && ($firstTime ||
-                                  ! $got->{$canonkey}[OFF_FIRST_ONLY]  ))
+        if ($got->{$canonkey})                                  
         {
             my $type = $got->{$canonkey}[OFF_TYPE] ;
             my $parsed = $parsed{$canonkey};
             ++ $parsed{$canonkey};
 
             return $self->setError("Muliple instances of '$key' found") 
-                if $parsed && ($type & Parse_multiple) == 0 ;
+                if $parsed ; 
 
             my $s ;
             $self->_checkType($key, $value, $type, 1, \$s)
                 or return undef ;
 
             $value = $$value ;
-            if ($type & Parse_multiple) {
-                $got->{$canonkey}[OFF_PARSED] = 1;
-                push @{ $got->{$canonkey}[OFF_FIXED] }, $s ;
-            }
-            else {
-                $got->{$canonkey} = [1, $type, $value, $s] ;
-            }
+            $got->{$canonkey} = [1, $type, $value, $s] ;
+
         }
         else
           { push (@Bad, $key) }
@@ -699,19 +697,19 @@ sub IO::Compress::Base::Parameters::_checkType
     if ($type & Parse_writable_scalar)
     {
         return $self->setError("Parameter '$key' not writable")
-            if $validate &&  readonly $$value ;
+            if  readonly $$value ;
 
         if (ref $$value) 
         {
             return $self->setError("Parameter '$key' not a scalar reference")
-                if $validate &&  ref $$value ne 'SCALAR' ;
+                if ref $$value ne 'SCALAR' ;
 
             $$output = $$value ;
         }
         else  
         {
             return $self->setError("Parameter '$key' not a scalar")
-                if $validate &&  ref $value ne 'SCALAR' ;
+                if ref $value ne 'SCALAR' ;
 
             $$output = $value ;
         }
@@ -719,14 +717,6 @@ sub IO::Compress::Base::Parameters::_checkType
         return 1;
     }
 
-#    if ($type & Parse_store_ref)
-#    {
-#        #$value = $$value
-#        #    if ref ${ $value } ;
-#
-#        $$output = $value ;
-#        return 1;
-#    }
 
     $value = $$value ;
 
@@ -737,20 +727,21 @@ sub IO::Compress::Base::Parameters::_checkType
     }
     elsif ($type & Parse_unsigned)
     {
+     
         return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
-            if $validate && ! defined $value ;
+            if ! defined $value ;
         return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
-            if $validate && $value !~ /^\d+$/;
-
+            if $value !~ /^\d+$/;
+    
         $$output = defined $value ? $value : 0 ;    
         return 1;
     }
     elsif ($type & Parse_signed)
     {
         return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
-            if $validate && ! defined $value ;
+            if ! defined $value ;
         return $self->setError("Parameter '$key' must be a signed int, got '$value'")
-            if $validate && $value !~ /^-?\d+$/;
+            if $value !~ /^-?\d+$/;
 
         $$output = defined $value ? $value : 0 ;    
         return 1 ;
@@ -758,50 +749,50 @@ sub IO::Compress::Base::Parameters::_checkType
     elsif ($type & Parse_boolean)
     {
         return $self->setError("Parameter '$key' must be an int, got '$value'")
-            if $validate && defined $value && $value !~ /^\d*$/;
-        $$output =  defined $value ? $value != 0 : 0 ;    
+            if defined $value && $value !~ /^\d*$/;
+
+        $$output =  defined $value && $value != 0 ? 1 : 0 ;    
         return 1;
     }
-    elsif ($type & Parse_code)
+
+    elsif ($type & Parse_string)
     {
-        return $self->setError("Parameter '$key' must be a code reference, got '$value'")
-            if $validate && (! defined $value || ref $value ne 'CODE') ;
         $$output = defined $value ? $value : "" ;    
         return 1;
     }
-    elsif ($type & Parse_string)
+    elsif ($type & Parse_code)
     {
+        return $self->setError("Parameter '$key' must be a code reference, got '$value'")
+            if (! defined $value || ref $value ne 'CODE') ;
+
         $$output = defined $value ? $value : "" ;    
         return 1;
     }
-
+    
     $$output = $value ;
     return 1;
 }
 
-
-
 sub IO::Compress::Base::Parameters::parsed
 {
-    my $self = shift ;
-    my $name = shift ;
-
-    return $self->{Got}{lc $name}[OFF_PARSED] ;
+    return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ;
 }
 
-sub IO::Compress::Base::Parameters::value
-{
-    my $self = shift ;
-    my $name = shift ;
 
-    if (@_)
-    {
-        $self->{Got}{lc $name}[OFF_PARSED]  = 1;
-        $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
-        $self->{Got}{lc $name}[OFF_FIXED]   = $_[0] ;
-    }
+sub IO::Compress::Base::Parameters::getValue
+{
+    return  $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ;
+}
+sub IO::Compress::Base::Parameters::setValue
+{
+    $_[0]->[IxGot]{$_[1]}[OFF_PARSED]  = 1;
+    $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ;
+    $_[0]->[IxGot]{$_[1]}[OFF_FIXED]   = $_[2] ;            
+}
 
-    return $self->{Got}{lc $name}[OFF_FIXED] ;
+sub IO::Compress::Base::Parameters::valueRef
+{
+    return  $_[0]->[IxGot]{$_[1]}[OFF_FIXED]  ;
 }
 
 sub IO::Compress::Base::Parameters::valueOrDefault
@@ -810,33 +801,31 @@ sub IO::Compress::Base::Parameters::valueOrDefault
     my $name = shift ;
     my $default = shift ;
 
-    my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
-
+    my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ;
+    
     return $value if defined $value ;
     return $default ;
 }
 
 sub IO::Compress::Base::Parameters::wantValue
 {
-    my $self = shift ;
-    my $name = shift ;
-
-    return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
-
+    return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ;
 }
 
 sub IO::Compress::Base::Parameters::clone
 {
     my $self = shift ;
-    my $obj = { };
+    my $obj = [] ;
     my %got ;
 
-    while (my ($k, $v) = each %{ $self->{Got} }) {
-        $got{$k} = [ @$v ];
+    my $hash = $self->[IxGot] ;
+    for my $k (keys %{ $hash })
+    {
+        $got{$k} = [ @{ $hash->{$k} } ];
     }
 
-    $obj->{Error} = $self->{Error};
-    $obj->{Got} = \%got ;
+    $obj->[IxError] = $self->[IxError];
+    $obj->[IxGot] = \%got ;
 
     return bless $obj, 'IO::Compress::Base::Parameters' ;
 }
@@ -850,27 +839,19 @@ use constant HIGH  => 1;
 
 sub new
 {
-    my $class = shift ;
-
-    my $high = 0 ;
-    my $low  = 0 ;
-
-    if (@_ == 2) {
-        $high = shift ;
-        $low  = shift ;
-    }
-    elsif (@_ == 1) {
-        $low  = shift ;
-    }
-
-    bless [$low, $high], $class;
+    return bless [ 0, 0 ], $_[0]
+        if @_ == 1 ;
+        
+    return bless [ $_[1], 0 ], $_[0]
+        if @_ == 2 ;
+        
+    return bless [ $_[2], $_[1] ], $_[0]      
+        if @_ == 3 ;  
 }
 
 sub newUnpack_V64
 {
-    my $string = shift;
-
-    my ($low, $hi) = unpack "V V", $string ;
+    my ($low, $hi) = unpack "V V", $_[0] ;
     bless [ $low, $hi ], "U64";
 }
 
@@ -884,64 +865,79 @@ sub newUnpack_V32
 
 sub reset
 {
-    my $self = shift;
-    $self->[HIGH] = $self->[LOW] = 0;
+    $_[0]->[HIGH] = $_[0]->[LOW] = 0;
 }
 
 sub clone
 {
-    my $self = shift;
-    bless [ @$self ], ref $self ;
+    bless [ @{$_[0]}  ], ref $_[0] ;    
 }
 
 sub getHigh
 {
-    my $self = shift;
-    return $self->[HIGH];
+    return $_[0]->[HIGH];
 }
 
 sub getLow
 {
-    my $self = shift;
-    return $self->[LOW];
+    return $_[0]->[LOW];
 }
 
 sub get32bit
 {
-    my $self = shift;
-    return $self->[LOW];
+    return $_[0]->[LOW];
 }
 
 sub get64bit
 {
-    my $self = shift;
     # Not using << here because the result will still be
     # a 32-bit value on systems where int size is 32-bits
-    return $self->[HIGH] * HI_1 + $self->[LOW];
+    return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW];
 }
 
 sub add
 {
-    my $self = shift;
-    my $value = shift;
+#    my $self = shift;
+    my $value = $_[1];
 
     if (ref $value eq 'U64') {
-        $self->[HIGH] += $value->[HIGH] ;
+        $_[0]->[HIGH] += $value->[HIGH] ;
         $value = $value->[LOW];
     }
     elsif ($value > MAX32) {      
-        $self->[HIGH] += int($value / HI_1) ;
+        $_[0]->[HIGH] += int($value / HI_1) ;
+        $value = $value % HI_1;
+    }
+     
+    my $available = MAX32 - $_[0]->[LOW] ;
+ 
+    if ($value > $available) {
+       ++ $_[0]->[HIGH] ;
+       $_[0]->[LOW] = $value - $available - 1;
+    }
+    else {
+       $_[0]->[LOW] += $value ;
+    }
+}
+
+sub add32
+{
+#    my $self = shift;
+    my $value = $_[1];
+
+    if ($value > MAX32) {      
+        $_[0]->[HIGH] += int($value / HI_1) ;
         $value = $value % HI_1;
     }
      
-    my $available = MAX32 - $self->[LOW] ;
+    my $available = MAX32 - $_[0]->[LOW] ;
  
     if ($value > $available) {
-       ++ $self->[HIGH] ;
-       $self->[LOW] = $value - $available - 1;
+       ++ $_[0]->[HIGH] ;
+       $_[0]->[LOW] = $value - $available - 1;
     }
     else {
-       $self->[LOW] += $value ;
+       $_[0]->[LOW] += $value ;
     }
 }
 
@@ -1005,35 +1001,27 @@ sub cmp
 
 sub is64bit
 {
-    my $self = shift;
-    return $self->[HIGH] > 0 ;
+    return $_[0]->[HIGH] > 0 ;
 }
 
 sub isAlmost64bit
 {
-    my $self = shift;
-    return $self->[HIGH] > 0 ||  $self->[LOW] == MAX32 ;
+    return $_[0]->[HIGH] > 0 ||  $_[0]->[LOW] == MAX32 ;
 }
 
 sub getPacked_V64
 {
-    my $self = shift;
-
-    return pack "V V", @$self ;
+    return pack "V V", @{ $_[0] } ;
 }
 
 sub getPacked_V32
 {
-    my $self = shift;
-
-    return pack "V", $self->[LOW] ;
+    return pack "V", $_[0]->[LOW] ;
 }
 
 sub pack_V64
 {
-    my $low  = shift;
-
-    return pack "V V", $low, 0;
+    return pack "V V", $_[0], 0;
 }