[p5sagit/p5-mst-13.2.git] / ext / IO / Compress / Base / lib / IO / Compress / Base / Common.pm

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);
@ISA = qw(Exporter);
$VERSION = '2.003';

@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput 
              isaFileGlobString cleanFileGlobString oneTarget
              setBinModeInput setBinModeOutput
              ckInOutParams 
              createSelfTiedObject

              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 STATUS_OK        =>  0;
#use constant STATUS_ENDSTREAM =>  1;
#use constant STATUS_ERROR     =>  2;
#use constant STATUS_EOF       =>  3;
          
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 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 Validator::saveErrorString
{
    my $self   = shift ;
    ${ $self->{Error} } = shift ;
    return undef;
    
}

sub Validator::croakError
{
    my $self   = shift ;
    $self->saveErrorString($_[0]);
    croak $_[0];
}


sub 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 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 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 $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;
Commit	Line	Data
25f0751f	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);
	13	@ISA = qw(Exporter);
b0cda13f	14	$VERSION = '2.003';
25f0751f	15
	16	@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput
	17	isaFileGlobString cleanFileGlobString oneTarget
	18	setBinModeInput setBinModeOutput
	19	ckInOutParams
	20	createSelfTiedObject
	21
	22	WANT_CODE
	23	WANT_EXT
	24	WANT_UNDEF
	25	WANT_HASH
	26
	27	STATUS_OK
	28	STATUS_ENDSTREAM
	29	STATUS_EOF
	30	STATUS_ERROR
	31	);
	32
	33	%EXPORT_TAGS = ( Status => [qw( STATUS_OK
	34	STATUS_ENDSTREAM
	35	STATUS_EOF
	36	STATUS_ERROR
	37	)]);
	38
	39
	40	use constant STATUS_OK => 0;
	41	use constant STATUS_ENDSTREAM => 1;
	42	use constant STATUS_EOF => 2;
	43	use constant STATUS_ERROR => -1;
	44	#use constant STATUS_OK => 0;
	45	#use constant STATUS_ENDSTREAM => 1;
	46	#use constant STATUS_ERROR => 2;
	47	#use constant STATUS_EOF => 3;
	48
	49	our ($needBinmode);
	50	$needBinmode = ($^O eq 'MSWin32' \|\|
	51	($] >= 5.006 && eval ' ${^UNICODE} \|\| ${^UTF8LOCALE} '))
	52	? 1 : 1 ;
	53
	54	sub setBinModeInput($)
	55	{
	56	my $handle = shift ;
	57
	58	binmode $handle
	59	if $needBinmode;
	60	}
	61
	62	sub setBinModeOutput($)
	63	{
	64	my $handle = shift ;
	65
	66	binmode $handle
	67	if $needBinmode;
	68	}
	69
	70	sub isaFilehandle($)
	71	{
	72	use utf8; # Pragma needed to keep Perl 5.6.0 happy
	73	return (defined $_[0] and
f6fd7794	74	(UNIVERSAL::isa($_[0],'GLOB') or
	75	UNIVERSAL::isa($_[0],'IO::Handle') or
	76	UNIVERSAL::isa(\$_[0],'GLOB'))
	77	)
25f0751f	78	}
	79
	80	sub isaFilename($)
	81	{
	82	return (defined $_[0] and
	83	! ref $_[0] and
	84	UNIVERSAL::isa(\$_[0], 'SCALAR'));
	85	}
	86
	87	sub isaFileGlobString
	88	{
	89	return defined $_[0] && $_[0] =~ /^<.*>$/;
	90	}
	91
	92	sub cleanFileGlobString
	93	{
	94	my $string = shift ;
	95
	96	$string =~ s/^\s<\s(.)\s>\s*$/$1/;
	97
	98	return $string;
	99	}
	100
	101	use constant WANT_CODE => 1 ;
	102	use constant WANT_EXT => 2 ;
	103	use constant WANT_UNDEF => 4 ;
	104	#use constant WANT_HASH => 8 ;
	105	use constant WANT_HASH => 0 ;
	106
	107	sub whatIsInput($;$)
	108	{
	109	my $got = whatIs(@_);
	110
	111	if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
	112	{
4ebc85a4	113	#use IO::File;
25f0751f	114	$got = 'handle';
4ebc85a4	115	$_[0] = *STDIN;
4ebc85a4	116	#$_[0] = new IO::File("<-");
25f0751f	117	}
	118
	119	return $got;
	120	}
	121
	122	sub whatIsOutput($;$)
	123	{
	124	my $got = whatIs(@_);
	125
	126	if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
	127	{
	128	$got = 'handle';
4ebc85a4	129	$_[0] = *STDOUT;
4ebc85a4	130	#$_[0] = new IO::File(">-");
25f0751f	131	}
	132
	133	return $got;
	134	}
	135
	136	sub whatIs ($;$)
	137	{
	138	return 'handle' if isaFilehandle($_[0]);
	139
	140	my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
	141	my $extended = defined $_[1] && $_[1] & WANT_EXT ;
	142	my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
	143	my $hash = defined $_[1] && $_[1] & WANT_HASH ;
	144
	145	return 'undef' if ! defined $_[0] && $undef ;
	146
	147	if (ref $_[0]) {
	148	return '' if blessed($_[0]); # is an object
	149	#return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
	150	return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
	151	return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
	152	return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
	153	return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
	154	return '';
	155	}
	156
	157	return 'fileglob' if $extended && isaFileGlobString($_[0]);
	158	return 'filename';
	159	}
	160
	161	sub oneTarget
	162	{
	163	return $_[0] =~ /^(code\|handle\|buffer\|filename)$/;
	164	}
	165
	166	sub Validator::new
	167	{
	168	my $class = shift ;
	169
	170	my $Class = shift ;
	171	my $error_ref = shift ;
	172	my $reportClass = shift ;
	173
	174	my %data = (Class => $Class,
	175	Error => $error_ref,
	176	reportClass => $reportClass,
	177	) ;
	178
	179	my $obj = bless \%data, $class ;
	180
	181	local $Carp::CarpLevel = 1;
	182
	183	my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT\|WANT_HASH);
	184	my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT\|WANT_HASH);
	185
	186	my $oneInput = $data{oneInput} = oneTarget($inType);
	187	my $oneOutput = $data{oneOutput} = oneTarget($outType);
	188
	189	if (! $inType)
	190	{
	191	$obj->croakError("$reportClass: illegal input parameter") ;
	192	#return undef ;
	193	}
	194
195	# if ($inType eq 'hash')
196	# {
197	# $obj->{Hash} = 1 ;
198	# $obj->{oneInput} = 1 ;
199	# return $obj->validateHash($_[0]);
200	# }
201
202	if (! $outType)
203	{
204	$obj->croakError("$reportClass: illegal output parameter") ;
205	#return undef ;
206	}
207
208
209	if ($inType ne 'fileglob' && $outType eq 'fileglob')
210	{
211	$obj->croakError("Need input fileglob for outout fileglob");
212	}
213
214	# if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
215	# {
216	# $obj->croakError("input must ne filename or fileglob when output is a hash");
217	# }
218
219	if ($inType eq 'fileglob' && $outType eq 'fileglob')
220	{
221	$data{GlobMap} = 1 ;
222	$data{inType} = $data{outType} = 'filename';
223	my $mapper = new File::GlobMapper($_[0], $_[1]);
224	if ( ! $mapper )
225	{
226	return $obj->saveErrorString($File::GlobMapper::Error) ;
227	}
228	$data{Pairs} = $mapper->getFileMap();
229
230	return $obj;
231	}
232
233	$obj->croakError("$reportClass: input and output $inType are identical")
234	if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
235
236	if ($inType eq 'fileglob') # && $outType ne 'fileglob'
237	{
238	my $glob = cleanFileGlobString($_[0]);
239	my @inputs = glob($glob);
240
241	if (@inputs == 0)
242	{
243	# TODO -- legal or die?
244	die "globmap matched zero file -- legal or die???" ;
245	}
246	elsif (@inputs == 1)
247	{
248	$obj->validateInputFilenames($inputs[0])
249	or return undef;
250	$_[0] = $inputs[0] ;
251	$data{inType} = 'filename' ;
252	$data{oneInput} = 1;
253	}
254	else
255	{
256	$obj->validateInputFilenames(@inputs)
257	or return undef;
258	$_[0] = [ @inputs ] ;
259	$data{inType} = 'filenames' ;
260	}
261	}
262	elsif ($inType eq 'filename')
263	{
264	$obj->validateInputFilenames($_[0])
265	or return undef;
266	}
267	elsif ($inType eq 'array')
268	{
269	$data{inType} = 'filenames' ;
270	$obj->validateInputArray($_[0])
271	or return undef ;
272	}
273
274	return $obj->saveErrorString("$reportClass: output buffer is read-only")
275	if $outType eq 'buffer' && readonly(${ $_[1] });
276
277	if ($outType eq 'filename' )
278	{
279	$obj->croakError("$reportClass: output filename is undef or null string")
280	if ! defined $_[1] \|\| $_[1] eq '' ;
e7d45986	281
	282	if (-e $_[1])
	283	{
	284	if (-d _ )
	285	{
	286	return $obj->saveErrorString("output file '$_[1]' is a directory");
	287	}
	288	}
25f0751f	289	}
	290
	291	return $obj ;
	292	}
	293
	294	sub Validator::saveErrorString
	295	{
	296	my $self = shift ;
	297	${ $self->{Error} } = shift ;
	298	return undef;
	299
	300	}
	301
	302	sub Validator::croakError
	303	{
	304	my $self = shift ;
	305	$self->saveErrorString($_[0]);
	306	croak $_[0];
	307	}
	308
	309
	310
	311	sub Validator::validateInputFilenames
	312	{
	313	my $self = shift ;
	314
	315	foreach my $filename (@_)
	316	{
	317	$self->croakError("$self->{reportClass}: input filename is undef or null string")
	318	if ! defined $filename \|\| $filename eq '' ;
	319
	320	next if $filename eq '-';
	321
	322	if (! -e $filename )
	323	{
	324	return $self->saveErrorString("input file '$filename' does not exist");
	325	}
	326
e7d45986	327	if (-d _ )
	328	{
	329	return $self->saveErrorString("input file '$filename' is a directory");
	330	}
	331
	332	if (! -r _ )
25f0751f	333	{
	334	return $self->saveErrorString("cannot open file '$filename': $!");
	335	}
	336	}
	337
	338	return 1 ;
	339	}
	340
	341	sub Validator::validateInputArray
	342	{
	343	my $self = shift ;
	344
	345	if ( @{ $_[0] } == 0 )
	346	{
	347	return $self->saveErrorString("empty array reference") ;
	348	}
	349
	350	foreach my $element ( @{ $_[0] } )
	351	{
	352	my $inType = whatIsInput($element);
	353
	354	if (! $inType)
	355	{
	356	$self->croakError("unknown input parameter") ;
	357	}
	358	elsif($inType eq 'filename')
	359	{
	360	$self->validateInputFilenames($element)
	361	or return undef ;
	362	}
	363	else
	364	{
	365	$self->croakError("not a filename") ;
	366	}
	367	}
	368
	369	return 1 ;
	370	}
	371
	372	#sub Validator::validateHash
	373	#{
	374	# my $self = shift ;
	375	# my $href = shift ;
	376	#
	377	# while (my($k, $v) = each %$href)
	378	# {
	379	# my $ktype = whatIsInput($k);
	380	# my $vtype = whatIsOutput($v, WANT_EXT\|WANT_UNDEF) ;
	381	#
	382	# if ($ktype ne 'filename')
	383	# {
	384	# return $self->saveErrorString("hash key not filename") ;
	385	# }
	386	#
	387	# my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
	388	# if (! $valid{$vtype})
	389	# {
	390	# return $self->saveErrorString("hash value not ok") ;
	391	# }
	392	# }
	393	#
	394	# return $self ;
	395	#}
	396
397	sub createSelfTiedObject
398	{
399	my $class = shift \|\| (caller)[0] ;
400	my $error_ref = shift ;
401
402	my $obj = bless Symbol::gensym(), ref($class) \|\| $class;
403	tie *$obj, $obj if $] >= 5.005;
404	*$obj->{Closed} = 1 ;
405	$$error_ref = '';
406	*$obj->{Error} = $error_ref ;
407	my $errno = 0 ;
408	*$obj->{ErrorNo} = \$errno ;
409
410	return $obj;
411	}
412
413
414
415	#package Parse::Parameters ;
416	#
417	#
418	#require Exporter;
419	#our ($VERSION, @ISA, @EXPORT);
420	#$VERSION = '2.000_08';
421	#@ISA = qw(Exporter);
422
423	$EXPORT_TAGS{Parse} = [qw( ParseParameters
424	Parse_any Parse_unsigned Parse_signed
425	Parse_boolean Parse_custom Parse_string
258133d1	426	Parse_multiple Parse_writable_scalar
25f0751f	427	)
	428	];
	429
	430	push @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
	431
	432	use constant Parse_any => 0x01;
	433	use constant Parse_unsigned => 0x02;
	434	use constant Parse_signed => 0x04;
	435	use constant Parse_boolean => 0x08;
	436	use constant Parse_string => 0x10;
	437	use constant Parse_custom => 0x12;
	438
258133d1	439	#use constant Parse_store_ref => 0x100 ;
	440	use constant Parse_multiple => 0x100 ;
	441	use constant Parse_writable => 0x200 ;
	442	use constant Parse_writable_scalar => 0x400 \| Parse_writable ;
25f0751f	443
	444	use constant OFF_PARSED => 0 ;
	445	use constant OFF_TYPE => 1 ;
	446	use constant OFF_DEFAULT => 2 ;
	447	use constant OFF_FIXED => 3 ;
	448	use constant OFF_FIRST_ONLY => 4 ;
	449	use constant OFF_STICKY => 5 ;
	450
	451
	452
	453	sub ParseParameters
	454	{
	455	my $level = shift \|\| 0 ;
	456
	457	my $sub = (caller($level + 1))[3] ;
	458	local $Carp::CarpLevel = 1 ;
	459	my $p = new IO::Compress::Base::Parameters() ;
	460	$p->parse(@_)
	461	or croak "$sub: $p->{Error}" ;
	462
	463	return $p;
	464	}
	465
	466	#package IO::Compress::Base::Parameters;
	467
	468	use strict;
	469	use warnings;
	470	use Carp;
	471
	472	sub IO::Compress::Base::Parameters::new
	473	{
	474	my $class = shift ;
	475
	476	my $obj = { Error => '',
	477	Got => {},
	478	} ;
	479
	480	#return bless $obj, ref($class) \|\| $class \|\| __PACKAGE__ ;
	481	return bless $obj, 'IO::Compress::Base::Parameters' ;
	482	}
	483
	484	sub IO::Compress::Base::Parameters::setError
	485	{
	486	my $self = shift ;
	487	my $error = shift ;
	488	my $retval = @_ ? shift : undef ;
	489
	490	$self->{Error} = $error ;
	491	return $retval;
	492	}
	493
	494	#sub getError
	495	#{
	496	# my $self = shift ;
	497	# return $self->{Error} ;
	498	#}
	499
	500	sub IO::Compress::Base::Parameters::parse
	501	{
	502	my $self = shift ;
	503
	504	my $default = shift ;
	505
	506	my $got = $self->{Got} ;
507	my $firstTime = keys %{ $got } == 0 ;
508
509	my (@Bad) ;
510	my @entered = () ;
511
512	# Allow the options to be passed as a hash reference or
513	# as the complete hash.
514	if (@_ == 0) {
515	@entered = () ;
516	}
517	elsif (@_ == 1) {
518	my $href = $_[0] ;
519	return $self->setError("Expected even number of parameters, got 1")
520	if ! defined $href or ! ref $href or ref $href ne "HASH" ;
521
522	foreach my $key (keys %$href) {
523	push @entered, $key ;
524	push @entered, \$href->{$key} ;
525	}
526	}
527	else {
528	my $count = @_;
529	return $self->setError("Expected even number of parameters, got $count")
530	if $count % 2 != 0 ;
531
532	for my $i (0.. $count / 2 - 1) {
533	push @entered, $_[2* $i] ;
534	push @entered, \$_[2* $i+1] ;
535	}
536	}
537
538
539	while (my ($key, $v) = each %$default)
540	{
541	croak "need 4 params [@$v]"
542	if @$v != 4 ;
543
544	my ($first_only, $sticky, $type, $value) = @$v ;
545	my $x ;
546	$self->_checkType($key, \$value, $type, 0, \$x)
547	or return undef ;
548
549	$key = lc $key;
550
551	if ($firstTime \|\| ! $sticky) {
258133d1	552	$x = [ $x ]
	553	if $type & Parse_multiple;
	554
25f0751f	555	$got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
	556	}
	557
	558	$got->{$key}[OFF_PARSED] = 0 ;
	559	}
	560
258133d1	561	my %parsed = ();
25f0751f	562	for my $i (0.. @entered / 2 - 1) {
	563	my $key = $entered[2* $i] ;
	564	my $value = $entered[2* $i+1] ;
	565
	566	#print "Key [$key] Value [$value]" ;
	567	#print defined $$value ? "[$$value]\n" : "[undef]\n";
	568
	569	$key =~ s/^-// ;
	570	my $canonkey = lc $key;
	571
	572	if ($got->{$canonkey} && ($firstTime \|\|
	573	! $got->{$canonkey}[OFF_FIRST_ONLY] ))
	574	{
	575	my $type = $got->{$canonkey}[OFF_TYPE] ;
258133d1	576	my $parsed = $parsed{$canonkey};
	577	++ $parsed{$canonkey};
	578
	579	return $self->setError("Muliple instances of '$key' found")
	580	if $parsed && $type & Parse_multiple == 0 ;
	581
25f0751f	582	my $s ;
	583	$self->_checkType($key, $value, $type, 1, \$s)
	584	or return undef ;
258133d1	585
25f0751f	586	$value = $$value ;
258133d1	587	if ($type & Parse_multiple) {
	588	$got->{$canonkey}[OFF_PARSED] = 1;
	589	push @{ $got->{$canonkey}[OFF_FIXED] }, $s ;
	590	}
	591	else {
	592	$got->{$canonkey} = [1, $type, $value, $s] ;
	593	}
25f0751f	594	}
	595	else
	596	{ push (@Bad, $key) }
	597	}
	598
	599	if (@Bad) {
	600	my ($bad) = join(", ", @Bad) ;
	601	return $self->setError("unknown key value(s) @Bad") ;
	602	}
	603
	604	return 1;
	605	}
	606
	607	sub IO::Compress::Base::Parameters::_checkType
	608	{
	609	my $self = shift ;
	610
	611	my $key = shift ;
	612	my $value = shift ;
	613	my $type = shift ;
	614	my $validate = shift ;
	615	my $output = shift;
	616
	617	#local $Carp::CarpLevel = $level ;
	618	#print "PARSE $type $key $value $validate $sub\n" ;
258133d1	619
258133d1	620	if ($type & Parse_writable_scalar)
25f0751f	621	{
258133d1	622	return $self->setError("Parameter '$key' not writable")
	623	if $validate && readonly $$value ;
	624
	625	if (ref $$value)
	626	{
	627	return $self->setError("Parameter '$key' not a scalar reference")
	628	if $validate && ref $$value ne 'SCALAR' ;
	629
	630	$$output = $$value ;
	631	}
	632	else
	633	{
	634	return $self->setError("Parameter '$key' not a scalar")
	635	if $validate && ref $value ne 'SCALAR' ;
	636
	637	$$output = $value ;
	638	}
25f0751f	639
25f0751f	640	return 1;
	641	}
	642
258133d1	643	# if ($type & Parse_store_ref)
	644	# {
	645	# #$value = $$value
	646	# # if ref ${ $value } ;
	647	#
	648	# $$output = $value ;
	649	# return 1;
	650	# }
	651
25f0751f	652	$value = $$value ;
	653
	654	if ($type & Parse_any)
	655	{
	656	$$output = $value ;
	657	return 1;
	658	}
	659	elsif ($type & Parse_unsigned)
	660	{
	661	return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
	662	if $validate && ! defined $value ;
	663	return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
	664	if $validate && $value !~ /^\d+$/;
	665
	666	$$output = defined $value ? $value : 0 ;
	667	return 1;
	668	}
	669	elsif ($type & Parse_signed)
	670	{
	671	return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
	672	if $validate && ! defined $value ;
	673	return $self->setError("Parameter '$key' must be a signed int, got '$value'")
	674	if $validate && $value !~ /^-?\d+$/;
	675
	676	$$output = defined $value ? $value : 0 ;
	677	return 1 ;
	678	}
	679	elsif ($type & Parse_boolean)
	680	{
	681	return $self->setError("Parameter '$key' must be an int, got '$value'")
	682	if $validate && defined $value && $value !~ /^\d*$/;
	683	$$output = defined $value ? $value != 0 : 0 ;
	684	return 1;
	685	}
	686	elsif ($type & Parse_string)
	687	{
	688	$$output = defined $value ? $value : "" ;
	689	return 1;
	690	}
	691
	692	$$output = $value ;
	693	return 1;
	694	}
	695
	696
	697
	698	sub IO::Compress::Base::Parameters::parsed
	699	{
	700	my $self = shift ;
	701	my $name = shift ;
	702
	703	return $self->{Got}{lc $name}[OFF_PARSED] ;
	704	}
	705
	706	sub IO::Compress::Base::Parameters::value
	707	{
	708	my $self = shift ;
	709	my $name = shift ;
	710
	711	if (@_)
	712	{
	713	$self->{Got}{lc $name}[OFF_PARSED] = 1;
	714	$self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
	715	$self->{Got}{lc $name}[OFF_FIXED] = $_[0] ;
716	}
717
718	return $self->{Got}{lc $name}[OFF_FIXED] ;
719	}
720
721	sub IO::Compress::Base::Parameters::valueOrDefault
722	{
723	my $self = shift ;
724	my $name = shift ;
725	my $default = shift ;
726
727	my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
728
729	return $value if defined $value ;
730	return $default ;
731	}
732
733	sub IO::Compress::Base::Parameters::wantValue
734	{
735	my $self = shift ;
736	my $name = shift ;
737
738	return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
739
740	}
741
742	sub IO::Compress::Base::Parameters::clone
743	{
744	my $self = shift ;
745	my $obj = { };
746	my %got ;
747
748	while (my ($k, $v) = each %{ $self->{Got} }) {
749	$got{$k} = [ @$v ];
750	}
751
752	$obj->{Error} = $self->{Error};
753	$obj->{Got} = \%got ;
754
755	return bless $obj, 'IO::Compress::Base::Parameters' ;
756	}
757
e7d45986	758	package U64;
	759
	760	use constant MAX32 => 0xFFFFFFFF ;
	761	use constant LOW => 0 ;
	762	use constant HIGH => 1;
	763
	764	sub new
	765	{
	766	my $class = shift ;
	767
	768	my $high = 0 ;
	769	my $low = 0 ;
	770
	771	if (@_ == 2) {
	772	$high = shift ;
	773	$low = shift ;
	774	}
	775	elsif (@_ == 1) {
	776	$low = shift ;
	777	}
	778
	779	bless [$low, $high], $class;
	780	}
	781
	782	sub newUnpack_V64
	783	{
	784	my $string = shift;
	785
	786	my ($low, $hi) = unpack "V V", $string ;
	787	bless [ $low, $hi ], "U64";
	788	}
	789
	790	sub newUnpack_V32
	791	{
	792	my $string = shift;
	793
	794	my $low = unpack "V", $string ;
	795	bless [ $low, 0 ], "U64";
	796	}
	797
	798	sub reset
	799	{
	800	my $self = shift;
	801	$self->[HIGH] = $self->[LOW] = 0;
	802	}
	803
	804	sub clone
	805	{
	806	my $self = shift;
	807	bless [ @$self ], ref $self ;
	808	}
	809
	810	sub getHigh
	811	{
	812	my $self = shift;
	813	return $self->[HIGH];
	814	}
	815
	816	sub getLow
	817	{
	818	my $self = shift;
	819	return $self->[LOW];
	820	}
	821
822	sub get32bit
823	{
824	my $self = shift;
825	return $self->[LOW];
826	}
827
828	sub add
829	{
830	my $self = shift;
831	my $value = shift;
832
833	if (ref $value eq 'U64') {
834	$self->[HIGH] += $value->[HIGH] ;
835	$value = $value->[LOW];
836	}
837
838	my $available = MAX32 - $self->[LOW] ;
839
840	if ($value > $available) {
841	++ $self->[HIGH] ;
842	$self->[LOW] = $value - $available - 1;
843	}
844	else {
845	$self->[LOW] += $value ;
846	}
847	}
848
849	sub equal
850	{
851	my $self = shift;
852	my $other = shift;
853
854	return $self->[LOW] == $other->[LOW] &&
855	$self->[HIGH] == $other->[HIGH] ;
856	}
857
858	sub getPacked_V64
859	{
860	my $self = shift;
861
862	return pack "V V", @$self ;
863	}
864
865	sub getPacked_V32
866	{
867	my $self = shift;
868
869	return pack "V", $self->[LOW] ;
870	}
871
872	sub pack_V64
873	{
874	my $low = shift;
875
876	return pack "V V", $low, 0;
877	}
878
879
25f0751f	880	package IO::Compress::Base::Common;
	881
	882	1;