summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2014-04-23 21:46:20 +0000
committerKarl Berry <karl@freefriends.org>2014-04-23 21:46:20 +0000
commit300c1eb6d37d46078d448d6d58938d5a80cd68ff (patch)
tree23a0a8b9f8f5460b405119c4d3c163d2d488ca5e /Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm
parented55d86b7c5e18f6eccce80a1fb1423ca40a23b5 (diff)
(tl)perl 5.18.2 for windows from siep
git-svn-id: svn://tug.org/texlive/trunk@33648 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm358
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;
}