--- /dev/null
+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.012';
+
+@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput
+ isaFileGlobString cleanFileGlobString oneTarget
+ setBinModeInput setBinModeOutput
+ ckInOutParams
+ createSelfTiedObject
+ getEncoding
+
+ 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;
+
+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 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_custom Parse_string
+ Parse_multiple 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_custom => 0x12;
+
+#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 ;
+
+
+
+sub ParseParameters
+{
+ my $level = shift || 0 ;
+
+ my $sub = (caller($level + 1))[3] ;
+ local $Carp::CarpLevel = 1 ;
+ my $p = new IO::Compress::Base::Parameters() ;
+ $p->parse(@_)
+ or croak "$sub: $p->{Error}" ;
+
+ return $p;
+}
+
+#package IO::Compress::Base::Parameters;
+
+use strict;
+use warnings;
+use Carp;
+
+sub IO::Compress::Base::Parameters::new
+{
+ my $class = shift ;
+
+ my $obj = { Error => '',
+ Got => {},
+ } ;
+
+ #return bless $obj, ref($class) || $class || __PACKAGE__ ;
+ return bless $obj, 'IO::Compress::Base::Parameters' ;
+}
+
+sub IO::Compress::Base::Parameters::setError
+{
+ my $self = shift ;
+ my $error = shift ;
+ my $retval = @_ ? shift : undef ;
+
+ $self->{Error} = $error ;
+ return $retval;
+}
+
+#sub getError
+#{
+# my $self = shift ;
+# return $self->{Error} ;
+#}
+
+sub IO::Compress::Base::Parameters::parse
+{
+ my $self = shift ;
+
+ my $default = shift ;
+
+ my $got = $self->{Got} ;
+ 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 $_[0]
+ if UNIVERSAL::isa($_[0], "IO::Compress::Base::Parameters");
+
+ 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] ;
+ }
+ }
+
+
+ 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 = [ $x ]
+ if $type & Parse_multiple;
+
+ $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
+ }
+
+ $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} && ($firstTime ||
+ ! $got->{$canonkey}[OFF_FIRST_ONLY] ))
+ {
+ 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 ;
+
+ 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] ;
+ }
+ }
+ 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 $validate && readonly $$value ;
+
+ if (ref $$value)
+ {
+ return $self->setError("Parameter '$key' not a scalar reference")
+ if $validate && ref $$value ne 'SCALAR' ;
+
+ $$output = $$value ;
+ }
+ else
+ {
+ return $self->setError("Parameter '$key' not a scalar")
+ if $validate && ref $value ne 'SCALAR' ;
+
+ $$output = $value ;
+ }
+
+ return 1;
+ }
+
+# if ($type & Parse_store_ref)
+# {
+# #$value = $$value
+# # if ref ${ $value } ;
+#
+# $$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 $validate && ! defined $value ;
+ return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
+ if $validate && $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 ;
+ return $self->setError("Parameter '$key' must be a signed int, got '$value'")
+ if $validate && $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 $validate && defined $value && $value !~ /^\d*$/;
+ $$output = defined $value ? $value != 0 : 0 ;
+ return 1;
+ }
+ elsif ($type & Parse_string)
+ {
+ $$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] ;
+}
+
+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] ;
+ }
+
+ return $self->{Got}{lc $name}[OFF_FIXED] ;
+}
+
+sub IO::Compress::Base::Parameters::valueOrDefault
+{
+ my $self = shift ;
+ my $name = shift ;
+ my $default = shift ;
+
+ my $value = $self->{Got}{lc $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] ;
+
+}
+
+sub IO::Compress::Base::Parameters::clone
+{
+ my $self = shift ;
+ my $obj = { };
+ my %got ;
+
+ while (my ($k, $v) = each %{ $self->{Got} }) {
+ $got{$k} = [ @$v ];
+ }
+
+ $obj->{Error} = $self->{Error};
+ $obj->{Got} = \%got ;
+
+ return bless $obj, 'IO::Compress::Base::Parameters' ;
+}
+
+package U64;
+
+use constant MAX32 => 0xFFFFFFFF ;
+use constant LOW => 0 ;
+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;
+}
+
+sub newUnpack_V64
+{
+ my $string = shift;
+
+ my ($low, $hi) = unpack "V V", $string ;
+ bless [ $low, $hi ], "U64";
+}
+
+sub newUnpack_V32
+{
+ my $string = shift;
+
+ my $low = unpack "V", $string ;
+ bless [ $low, 0 ], "U64";
+}
+
+sub reset
+{
+ my $self = shift;
+ $self->[HIGH] = $self->[LOW] = 0;
+}
+
+sub clone
+{
+ my $self = shift;
+ bless [ @$self ], ref $self ;
+}
+
+sub getHigh
+{
+ my $self = shift;
+ return $self->[HIGH];
+}
+
+sub getLow
+{
+ my $self = shift;
+ return $self->[LOW];
+}
+
+sub get32bit
+{
+ my $self = shift;
+ return $self->[LOW];
+}
+
+sub add
+{
+ my $self = shift;
+ my $value = shift;
+
+ if (ref $value eq 'U64') {
+ $self->[HIGH] += $value->[HIGH] ;
+ $value = $value->[LOW];
+ }
+
+ my $available = MAX32 - $self->[LOW] ;
+
+ if ($value > $available) {
+ ++ $self->[HIGH] ;
+ $self->[LOW] = $value - $available - 1;
+ }
+ else {
+ $self->[LOW] += $value ;
+ }
+}
+
+sub equal
+{
+ my $self = shift;
+ my $other = shift;
+
+ return $self->[LOW] == $other->[LOW] &&
+ $self->[HIGH] == $other->[HIGH] ;
+}
+
+sub getPacked_V64
+{
+ my $self = shift;
+
+ return pack "V V", @$self ;
+}
+
+sub getPacked_V32
+{
+ my $self = shift;
+
+ return pack "V", $self->[LOW] ;
+}
+
+sub pack_V64
+{
+ my $low = shift;
+
+ return pack "V V", $low, 0;
+}
+
+
+package IO::Compress::Base::Common;
+
+1;
projects / dh-make-perl / blobdiff