package IO::Compress::Base::Common; use strict ; use warnings; use bytes; use Carp; use Scalar::Util qw(blessed readonly); use File::GlobMapper; require Exporter; our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE); @ISA = qw(Exporter); $VERSION = '2.096'; @EXPORT = qw( isaFilehandle isaFilename isaScalar whatIsInput whatIsOutput isaFileGlobString cleanFileGlobString oneTarget setBinModeInput setBinModeOutput ckInOutParams createSelfTiedObject isGeMax32 MAX32 WANT_CODE WANT_EXT WANT_UNDEF WANT_HASH STATUS_OK STATUS_ENDSTREAM STATUS_EOF STATUS_ERROR ); %EXPORT_TAGS = ( Status => [qw( STATUS_OK STATUS_ENDSTREAM STATUS_EOF STATUS_ERROR )]); use constant STATUS_OK => 0; use constant STATUS_ENDSTREAM => 1; use constant STATUS_EOF => 2; use constant STATUS_ERROR => -1; use constant MAX16 => 0xFFFF ; use constant MAX32 => 0xFFFFFFFF ; use constant MAX32cmp => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value sub isGeMax32 { return $_[0] >= MAX32cmp ; } sub hasEncode() { if (! defined $HAS_ENCODE) { eval { require Encode; Encode->import(); }; $HAS_ENCODE = $@ ? 0 : 1 ; } return $HAS_ENCODE; } sub getEncoding($$$) { my $obj = shift; my $class = shift ; my $want_encoding = shift ; $obj->croakError("$class: Encode module needed to use -Encode") if ! hasEncode(); my $encoding = Encode::find_encoding($want_encoding); $obj->croakError("$class: Encoding '$want_encoding' is not available") if ! $encoding; return $encoding; } our ($needBinmode); $needBinmode = ($^O eq 'MSWin32' || ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} ')) ? 1 : 1 ; sub setBinModeInput($) { my $handle = shift ; binmode $handle if $needBinmode; } sub setBinModeOutput($) { my $handle = shift ; binmode $handle if $needBinmode; } sub isaFilehandle($) { use utf8; # Pragma needed to keep Perl 5.6.0 happy return (defined $_[0] and (UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa($_[0],'IO::Handle') or UNIVERSAL::isa(\$_[0],'GLOB')) ) } sub isaScalar { return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ; } sub isaFilename($) { return (defined $_[0] and ! ref $_[0] and UNIVERSAL::isa(\$_[0], 'SCALAR')); } sub isaFileGlobString { return defined $_[0] && $_[0] =~ /^<.*>$/; } sub cleanFileGlobString { my $string = shift ; $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; return $string; } use constant WANT_CODE => 1 ; use constant WANT_EXT => 2 ; use constant WANT_UNDEF => 4 ; #use constant WANT_HASH => 8 ; use constant WANT_HASH => 0 ; sub whatIsInput($;$) { my $got = whatIs(@_); if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') { #use IO::File; $got = 'handle'; $_[0] = *STDIN; #$_[0] = new IO::File("<-"); } return $got; } sub whatIsOutput($;$) { my $got = whatIs(@_); if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') { $got = 'handle'; $_[0] = *STDOUT; #$_[0] = new IO::File(">-"); } return $got; } sub whatIs ($;$) { return 'handle' if isaFilehandle($_[0]); my $wantCode = defined $_[1] && $_[1] & WANT_CODE ; my $extended = defined $_[1] && $_[1] & WANT_EXT ; my $undef = defined $_[1] && $_[1] & WANT_UNDEF ; my $hash = defined $_[1] && $_[1] & WANT_HASH ; return 'undef' if ! defined $_[0] && $undef ; if (ref $_[0]) { return '' if blessed($_[0]); # is an object #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR'); return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ; return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ; return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ; return ''; } return 'fileglob' if $extended && isaFileGlobString($_[0]); return 'filename'; } sub oneTarget { return $_[0] =~ /^(code|handle|buffer|filename)$/; } sub IO::Compress::Base::Validator::new { my $class = shift ; my $Class = shift ; my $error_ref = shift ; my $reportClass = shift ; my %data = (Class => $Class, Error => $error_ref, reportClass => $reportClass, ) ; my $obj = bless \%data, $class ; local $Carp::CarpLevel = 1; my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH); my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH); my $oneInput = $data{oneInput} = oneTarget($inType); my $oneOutput = $data{oneOutput} = oneTarget($outType); if (! $inType) { $obj->croakError("$reportClass: illegal input parameter") ; #return undef ; } # if ($inType eq 'hash') # { # $obj->{Hash} = 1 ; # $obj->{oneInput} = 1 ; # return $obj->validateHash($_[0]); # } if (! $outType) { $obj->croakError("$reportClass: illegal output parameter") ; #return undef ; } if ($inType ne 'fileglob' && $outType eq 'fileglob') { $obj->croakError("Need input fileglob for outout fileglob"); } # if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' ) # { # $obj->croakError("input must ne filename or fileglob when output is a hash"); # } if ($inType eq 'fileglob' && $outType eq 'fileglob') { $data{GlobMap} = 1 ; $data{inType} = $data{outType} = 'filename'; my $mapper = new File::GlobMapper($_[0], $_[1]); if ( ! $mapper ) { return $obj->saveErrorString($File::GlobMapper::Error) ; } $data{Pairs} = $mapper->getFileMap(); return $obj; } $obj->croakError("$reportClass: input and output $inType are identical") if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ; if ($inType eq 'fileglob') # && $outType ne 'fileglob' { my $glob = cleanFileGlobString($_[0]); my @inputs = glob($glob); if (@inputs == 0) { # TODO -- legal or die? die "globmap matched zero file -- legal or die???" ; } elsif (@inputs == 1) { $obj->validateInputFilenames($inputs[0]) or return undef; $_[0] = $inputs[0] ; $data{inType} = 'filename' ; $data{oneInput} = 1; } else { $obj->validateInputFilenames(@inputs) or return undef; $_[0] = [ @inputs ] ; $data{inType} = 'filenames' ; } } elsif ($inType eq 'filename') { $obj->validateInputFilenames($_[0]) or return undef; } elsif ($inType eq 'array') { $data{inType} = 'filenames' ; $obj->validateInputArray($_[0]) or return undef ; } return $obj->saveErrorString("$reportClass: output buffer is read-only") if $outType eq 'buffer' && readonly(${ $_[1] }); if ($outType eq 'filename' ) { $obj->croakError("$reportClass: output filename is undef or null string") if ! defined $_[1] || $_[1] eq '' ; if (-e $_[1]) { if (-d _ ) { return $obj->saveErrorString("output file '$_[1]' is a directory"); } } } return $obj ; } sub IO::Compress::Base::Validator::saveErrorString { my $self = shift ; ${ $self->{Error} } = shift ; return undef; } sub IO::Compress::Base::Validator::croakError { my $self = shift ; $self->saveErrorString($_[0]); croak $_[0]; } sub IO::Compress::Base::Validator::validateInputFilenames { my $self = shift ; foreach my $filename (@_) { $self->croakError("$self->{reportClass}: input filename is undef or null string") if ! defined $filename || $filename eq '' ; next if $filename eq '-'; if (! -e $filename ) { return $self->saveErrorString("input file '$filename' does not exist"); } if (-d _ ) { return $self->saveErrorString("input file '$filename' is a directory"); } # if (! -r _ ) # { # return $self->saveErrorString("cannot open file '$filename': $!"); # } } return 1 ; } sub IO::Compress::Base::Validator::validateInputArray { my $self = shift ; if ( @{ $_[0] } == 0 ) { return $self->saveErrorString("empty array reference") ; } foreach my $element ( @{ $_[0] } ) { my $inType = whatIsInput($element); if (! $inType) { $self->croakError("unknown input parameter") ; } elsif($inType eq 'filename') { $self->validateInputFilenames($element) or return undef ; } else { $self->croakError("not a filename") ; } } return 1 ; } #sub IO::Compress::Base::Validator::validateHash #{ # my $self = shift ; # my $href = shift ; # # while (my($k, $v) = each %$href) # { # my $ktype = whatIsInput($k); # my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ; # # if ($ktype ne 'filename') # { # return $self->saveErrorString("hash key not filename") ; # } # # my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ; # if (! $valid{$vtype}) # { # return $self->saveErrorString("hash value not ok") ; # } # } # # return $self ; #} sub createSelfTiedObject { my $class = shift || (caller)[0] ; my $error_ref = shift ; my $obj = bless Symbol::gensym(), ref($class) || $class; tie *$obj, $obj if $] >= 5.005; *$obj->{Closed} = 1 ; $$error_ref = ''; *$obj->{Error} = $error_ref ; my $errno = 0 ; *$obj->{ErrorNo} = \$errno ; return $obj; } #package Parse::Parameters ; # # #require Exporter; #our ($VERSION, @ISA, @EXPORT); #$VERSION = '2.000_08'; #@ISA = qw(Exporter); $EXPORT_TAGS{Parse} = [qw( ParseParameters Parse_any Parse_unsigned Parse_signed Parse_boolean Parse_string Parse_code Parse_writable_scalar ) ]; push @EXPORT, @{ $EXPORT_TAGS{Parse} } ; use constant Parse_any => 0x01; use constant Parse_unsigned => 0x02; use constant Parse_signed => 0x04; use constant Parse_boolean => 0x08; use constant Parse_string => 0x10; use constant Parse_code => 0x20; #use constant Parse_store_ref => 0x100 ; #use constant Parse_multiple => 0x100 ; use constant Parse_writable => 0x200 ; use constant Parse_writable_scalar => 0x400 | Parse_writable ; 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 IxError => 0; use constant IxGot => 1 ; sub ParseParameters { my $level = shift || 0 ; my $sub = (caller($level + 1))[3] ; local $Carp::CarpLevel = 1 ; return $_[1] if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters"); my $p = new IO::Compress::Base::Parameters() ; $p->parse(@_) or croak "$sub: $p->[IxError]" ; return $p; } 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 $obj; $obj->[IxError] = ''; $obj->[IxGot] = {} ; return bless $obj, 'IO::Compress::Base::Parameters' ; } sub IO::Compress::Base::Parameters::setError { my $self = shift ; my $error = shift ; my $retval = @_ ? shift : undef ; $self->[IxError] = $error ; return $retval; } 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->[IxGot] ; my $firstTime = keys %{ $got } == 0 ; my (@Bad) ; my @entered = () ; # Allow the options to be passed as a hash reference or # as the complete hash. if (@_ == 0) { @entered = () ; } elsif (@_ == 1) { my $href = $_[0] ; return $self->setError("Expected even number of parameters, got 1") if ! defined $href or ! ref $href or ref $href ne "HASH" ; foreach my $key (keys %$href) { push @entered, $key ; push @entered, \$href->{$key} ; } } else { my $count = @_; return $self->setError("Expected even number of parameters, got $count") if $count % 2 != 0 ; for my $i (0.. $count / 2 - 1) { push @entered, $_[2 * $i] ; push @entered, \$_[2 * $i + 1] ; } } foreach my $key (keys %$default) { my ($type, $value) = @{ $default->{$key} } ; if ($firstTime) { $got->{$key} = [0, $type, $value, $value] ; } else { $got->{$key}[OFF_PARSED] = 0 ; } } my %parsed = (); for my $i (0.. @entered / 2 - 1) { my $key = $entered[2* $i] ; my $value = $entered[2* $i+1] ; #print "Key [$key] Value [$value]" ; #print defined $$value ? "[$$value]\n" : "[undef]\n"; $key =~ s/^-// ; my $canonkey = lc $key; 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 ; my $s ; $self->_checkType($key, $value, $type, 1, \$s) or return undef ; $value = $$value ; $got->{$canonkey} = [1, $type, $value, $s] ; } else { push (@Bad, $key) } } if (@Bad) { my ($bad) = join(", ", @Bad) ; return $self->setError("unknown key value(s) $bad") ; } return 1; } sub IO::Compress::Base::Parameters::_checkType { my $self = shift ; my $key = shift ; my $value = shift ; my $type = shift ; my $validate = shift ; my $output = shift; #local $Carp::CarpLevel = $level ; #print "PARSE $type $key $value $validate $sub\n" ; if ($type & Parse_writable_scalar) { return $self->setError("Parameter '$key' not writable") if readonly $$value ; if (ref $$value) { return $self->setError("Parameter '$key' not a scalar reference") if ref $$value ne 'SCALAR' ; $$output = $$value ; } else { return $self->setError("Parameter '$key' not a scalar") if ref $value ne 'SCALAR' ; $$output = $value ; } return 1; } $value = $$value ; if ($type & Parse_any) { $$output = $value ; return 1; } elsif ($type & Parse_unsigned) { return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'") if ! defined $value ; return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") 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 ! defined $value ; return $self->setError("Parameter '$key' must be a signed int, got '$value'") if $value !~ /^-?\d+$/; $$output = defined $value ? $value : 0 ; return 1 ; } elsif ($type & Parse_boolean) { return $self->setError("Parameter '$key' must be an int, got '$value'") if defined $value && $value !~ /^\d*$/; $$output = defined $value && $value != 0 ? 1 : 0 ; return 1; } elsif ($type & Parse_string) { $$output = defined $value ? $value : "" ; return 1; } 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 { return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ; } 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] ; } sub IO::Compress::Base::Parameters::valueRef { return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ; } sub IO::Compress::Base::Parameters::valueOrDefault { my $self = shift ; my $name = shift ; my $default = shift ; my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ; return $value if defined $value ; return $default ; } sub IO::Compress::Base::Parameters::wantValue { return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ; } sub IO::Compress::Base::Parameters::clone { my $self = shift ; my $obj = [] ; my %got ; my $hash = $self->[IxGot] ; for my $k (keys %{ $hash }) { $got{$k} = [ @{ $hash->{$k} } ]; } $obj->[IxError] = $self->[IxError]; $obj->[IxGot] = \%got ; return bless $obj, 'IO::Compress::Base::Parameters' ; } package U64; use constant MAX32 => 0xFFFFFFFF ; use constant HI_1 => MAX32 + 1 ; use constant LOW => 0 ; use constant HIGH => 1; sub new { 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 ($low, $hi) = unpack "V V", $_[0] ; bless [ $low, $hi ], "U64"; } sub newUnpack_V32 { my $string = shift; my $low = unpack "V", $string ; bless [ $low, 0 ], "U64"; } sub reset { $_[0]->[HIGH] = $_[0]->[LOW] = 0; } sub clone { bless [ @{$_[0]} ], ref $_[0] ; } sub getHigh { return $_[0]->[HIGH]; } sub getLow { return $_[0]->[LOW]; } sub get32bit { return $_[0]->[LOW]; } sub get64bit { # Not using << here because the result will still be # a 32-bit value on systems where int size is 32-bits return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW]; } sub add { # my $self = shift; my $value = $_[1]; if (ref $value eq 'U64') { $_[0]->[HIGH] += $value->[HIGH] ; $value = $value->[LOW]; } elsif ($value > MAX32) { $_[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 - $_[0]->[LOW] ; if ($value > $available) { ++ $_[0]->[HIGH] ; $_[0]->[LOW] = $value - $available - 1; } else { $_[0]->[LOW] += $value ; } } sub subtract { my $self = shift; my $value = shift; if (ref $value eq 'U64') { if ($value->[HIGH]) { die "bad" if $self->[HIGH] == 0 || $value->[HIGH] > $self->[HIGH] ; $self->[HIGH] -= $value->[HIGH] ; } $value = $value->[LOW] ; } if ($value > $self->[LOW]) { -- $self->[HIGH] ; $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ; } else { $self->[LOW] -= $value; } } sub equal { my $self = shift; my $other = shift; return $self->[LOW] == $other->[LOW] && $self->[HIGH] == $other->[HIGH] ; } sub isZero { my $self = shift; return $self->[LOW] == 0 && $self->[HIGH] == 0 ; } sub gt { my $self = shift; my $other = shift; return $self->cmp($other) > 0 ; } sub cmp { my $self = shift; my $other = shift ; if ($self->[LOW] == $other->[LOW]) { return $self->[HIGH] - $other->[HIGH] ; } else { return $self->[LOW] - $other->[LOW] ; } } sub is64bit { return $_[0]->[HIGH] > 0 ; } sub isAlmost64bit { return $_[0]->[HIGH] > 0 || $_[0]->[LOW] == MAX32 ; } sub getPacked_V64 { return pack "V V", @{ $_[0] } ; } sub getPacked_V32 { return pack "V", $_[0]->[LOW] ; } sub pack_V64 { return pack "V V", $_[0], 0; } sub full32 { return $_[0] == MAX32 ; } sub Value_VV64 { my $buffer = shift; my ($lo, $hi) = unpack ("V V" , $buffer); no warnings 'uninitialized'; return $hi * HI_1 + $lo; } package IO::Compress::Base::Common; 1;