[p5sagit/p5-mst-13.2.git] / cpan / IO-Compress / 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, $HAS_ENCODE);
@ISA = qw(Exporter);
$VERSION = '2.021';

@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 ;
    
    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->{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 $other;

    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) {
            if ($_[2 * $i] eq '__xxx__') {
                $other = $_[2 * $i + 1] ;
            }
            else {
                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 = ();
    
    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] ;

        #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 HI_1 => MAX32 + 1 ;
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 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];
}

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 is64bit
{
    my $self = shift;
    return $self->[HIGH] > 0 ;
}

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