[p5sagit/p5-mst-13.2.git] / ext / Compress / IO / 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.000_10';

@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],'GLOB')) 
                 and defined fileno($_[0])  )
}

sub isaFilename($)
{
    return (defined $_[0] and 
           ! ref $_[0]    and 
           UNIVERSAL::isa(\$_[0], 'SCALAR'));
}

sub isaFileGlobString
{
    return defined $_[0] && $_[0] =~ /^<.*>$/;
}

sub cleanFileGlobString
{
    my $string = shift ;

    $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;

    return $string;
}

use constant WANT_CODE  => 1 ;
use constant WANT_EXT   => 2 ;
use constant WANT_UNDEF => 4 ;
#use constant WANT_HASH  => 8 ;
use constant WANT_HASH  => 0 ;

sub whatIsInput($;$)
{
    my $got = whatIs(@_);
    
    if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
    {
        use IO::File;
        $got = 'handle';
        #$_[0] = \*STDIN;
        $_[0] = new IO::File("<-");
    }

    return $got;
}

sub whatIsOutput($;$)
{
    my $got = whatIs(@_);
    
    if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
    {
        $got = 'handle';
        #$_[0] = \*STDOUT;
        $_[0] = new IO::File(">-");
    }
    
    return $got;
}

sub whatIs ($;$)
{
    return 'handle' if isaFilehandle($_[0]);

    my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
    my $extended = defined $_[1] && $_[1] & WANT_EXT ;
    my $undef    = defined $_[1] && $_[1] & WANT_UNDEF ;
    my $hash     = defined $_[1] && $_[1] & WANT_HASH ;

    return 'undef'  if ! defined $_[0] && $undef ;

    if (ref $_[0]) {
        return ''       if blessed($_[0]); # is an object
        #return ''       if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
        return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
        return 'array'  if UNIVERSAL::isa($_[0], 'ARRAY')  && $extended ;
        return 'hash'   if UNIVERSAL::isa($_[0], 'HASH')   && $hash ;
        return 'code'   if UNIVERSAL::isa($_[0], 'CODE')   && $wantCode ;
        return '';
    }

    return 'fileglob' if $extended && isaFileGlobString($_[0]);
    return 'filename';
}

sub oneTarget
{
    return $_[0] =~ /^(code|handle|buffer|filename)$/;
}

sub 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 ''  ;
    }
    
    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 (! -r $filename )
        {
            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_store_ref
                         )
                      ];              

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 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) {
            $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
        }

        $got->{$key}[OFF_PARSED] = 0 ;
    }

    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 $s ;
            $self->_checkType($key, $value, $type, 1, \$s)
                or return undef ;
            #$value = $$value unless $type & Parse_store_ref ;
            $value = $$value ;
            $got->{$canonkey} = [1, $type, $value, $s] ;
        }
        else
          { push (@Bad, $key) }
    }
 
    if (@Bad) {
        my ($bad) = join(", ", @Bad) ;
        return $self->setError("unknown key value(s) @Bad") ;
    }

    return 1;
}

sub IO::Compress::Base::Parameters::_checkType
{
    my $self = shift ;

    my $key   = shift ;
    my $value = shift ;
    my $type  = shift ;
    my $validate  = shift ;
    my $output  = shift;

    #local $Carp::CarpLevel = $level ;
    #print "PARSE $type $key $value $validate $sub\n" ;
    if ( $type & Parse_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 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);
cb7abd7f	14	$VERSION = '2.000_10';
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
	74	(UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa(\$_[0],'GLOB'))
	75	and defined fileno($_[0]) )
	76	}
	77
	78	sub isaFilename($)
79	{
80	return (defined $_[0] and
81	! ref $_[0] and
82	UNIVERSAL::isa(\$_[0], 'SCALAR'));
83	}
84
85	sub isaFileGlobString
86	{
87	return defined $_[0] && $_[0] =~ /^<.*>$/;
88	}
89
90	sub cleanFileGlobString
91	{
92	my $string = shift ;
93
94	$string =~ s/^\s<\s(.)\s>\s*$/$1/;
95
96	return $string;
97	}
98
99	use constant WANT_CODE => 1 ;
100	use constant WANT_EXT => 2 ;
101	use constant WANT_UNDEF => 4 ;
102	#use constant WANT_HASH => 8 ;
103	use constant WANT_HASH => 0 ;
104
105	sub whatIsInput($;$)
106	{
107	my $got = whatIs(@_);
108
109	if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
110	{
111	use IO::File;
112	$got = 'handle';
113	#$_[0] = \*STDIN;
114	$_[0] = new IO::File("<-");
115	}
116
117	return $got;
118	}
119
120	sub whatIsOutput($;$)
121	{
122	my $got = whatIs(@_);
123
124	if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
125	{
126	$got = 'handle';
127	#$_[0] = \*STDOUT;
128	$_[0] = new IO::File(">-");
129	}
130
131	return $got;
132	}
133
134	sub whatIs ($;$)
135	{
136	return 'handle' if isaFilehandle($_[0]);
137
138	my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
139	my $extended = defined $_[1] && $_[1] & WANT_EXT ;
140	my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
141	my $hash = defined $_[1] && $_[1] & WANT_HASH ;
142
143	return 'undef' if ! defined $_[0] && $undef ;
144
145	if (ref $_[0]) {
146	return '' if blessed($_[0]); # is an object
147	#return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
148	return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
149	return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
150	return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
151	return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
152	return '';
153	}
154
155	return 'fileglob' if $extended && isaFileGlobString($_[0]);
156	return 'filename';
157	}
158
159	sub oneTarget
160	{
161	return $_[0] =~ /^(code\|handle\|buffer\|filename)$/;
162	}
163
164	sub Validator::new
165	{
166	my $class = shift ;
167
168	my $Class = shift ;
169	my $error_ref = shift ;
170	my $reportClass = shift ;
171
172	my %data = (Class => $Class,
173	Error => $error_ref,
174	reportClass => $reportClass,
175	) ;
176
177	my $obj = bless \%data, $class ;
178
179	local $Carp::CarpLevel = 1;
180
181	my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT\|WANT_HASH);
182	my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT\|WANT_HASH);
183
184	my $oneInput = $data{oneInput} = oneTarget($inType);
185	my $oneOutput = $data{oneOutput} = oneTarget($outType);
186
187	if (! $inType)
188	{
189	$obj->croakError("$reportClass: illegal input parameter") ;
190	#return undef ;
191	}
192
193	# if ($inType eq 'hash')
194	# {
195	# $obj->{Hash} = 1 ;
196	# $obj->{oneInput} = 1 ;
197	# return $obj->validateHash($_[0]);
198	# }
199
200	if (! $outType)
201	{
202	$obj->croakError("$reportClass: illegal output parameter") ;
203	#return undef ;
204	}
205
206
207	if ($inType ne 'fileglob' && $outType eq 'fileglob')
208	{
209	$obj->croakError("Need input fileglob for outout fileglob");
210	}
211
212	# if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
213	# {
214	# $obj->croakError("input must ne filename or fileglob when output is a hash");
215	# }
216
217	if ($inType eq 'fileglob' && $outType eq 'fileglob')
218	{
219	$data{GlobMap} = 1 ;
220	$data{inType} = $data{outType} = 'filename';
221	my $mapper = new File::GlobMapper($_[0], $_[1]);
222	if ( ! $mapper )
223	{
224	return $obj->saveErrorString($File::GlobMapper::Error) ;
225	}
226	$data{Pairs} = $mapper->getFileMap();
227
228	return $obj;
229	}
230
231	$obj->croakError("$reportClass: input and output $inType are identical")
232	if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
233
234	if ($inType eq 'fileglob') # && $outType ne 'fileglob'
235	{
236	my $glob = cleanFileGlobString($_[0]);
237	my @inputs = glob($glob);
238
239	if (@inputs == 0)
240	{
241	# TODO -- legal or die?
242	die "globmap matched zero file -- legal or die???" ;
243	}
244	elsif (@inputs == 1)
245	{
246	$obj->validateInputFilenames($inputs[0])
247	or return undef;
248	$_[0] = $inputs[0] ;
249	$data{inType} = 'filename' ;
250	$data{oneInput} = 1;
251	}
252	else
253	{
254	$obj->validateInputFilenames(@inputs)
255	or return undef;
256	$_[0] = [ @inputs ] ;
257	$data{inType} = 'filenames' ;
258	}
259	}
260	elsif ($inType eq 'filename')
261	{
262	$obj->validateInputFilenames($_[0])
263	or return undef;
264	}
265	elsif ($inType eq 'array')
266	{
267	$data{inType} = 'filenames' ;
268	$obj->validateInputArray($_[0])
269	or return undef ;
270	}
271
272	return $obj->saveErrorString("$reportClass: output buffer is read-only")
273	if $outType eq 'buffer' && readonly(${ $_[1] });
274
275	if ($outType eq 'filename' )
276	{
277	$obj->croakError("$reportClass: output filename is undef or null string")
278	if ! defined $_[1] \|\| $_[1] eq '' ;
279	}
280
281	return $obj ;
282	}
283
284	sub Validator::saveErrorString
285	{
286	my $self = shift ;
287	${ $self->{Error} } = shift ;
288	return undef;
289
290	}
291
292	sub Validator::croakError
293	{
294	my $self = shift ;
295	$self->saveErrorString($_[0]);
296	croak $_[0];
297	}
298
299
300
301	sub Validator::validateInputFilenames
302	{
303	my $self = shift ;
304
305	foreach my $filename (@_)
306	{
307	$self->croakError("$self->{reportClass}: input filename is undef or null string")
308	if ! defined $filename \|\| $filename eq '' ;
309
310	next if $filename eq '-';
311
312	if (! -e $filename )
313	{
314	return $self->saveErrorString("input file '$filename' does not exist");
315	}
316
317	if (! -r $filename )
318	{
319	return $self->saveErrorString("cannot open file '$filename': $!");
320	}
321	}
322
323	return 1 ;
324	}
325
326	sub Validator::validateInputArray
327	{
328	my $self = shift ;
329
330	if ( @{ $_[0] } == 0 )
331	{
332	return $self->saveErrorString("empty array reference") ;
333	}
334
335	foreach my $element ( @{ $_[0] } )
336	{
337	my $inType = whatIsInput($element);
338
339	if (! $inType)
340	{
341	$self->croakError("unknown input parameter") ;
342	}
343	elsif($inType eq 'filename')
344	{
345	$self->validateInputFilenames($element)
346	or return undef ;
347	}
348	else
349	{
350	$self->croakError("not a filename") ;
351	}
352	}
353
354	return 1 ;
355	}
356
357	#sub Validator::validateHash
358	#{
359	# my $self = shift ;
360	# my $href = shift ;
361	#
362	# while (my($k, $v) = each %$href)
363	# {
364	# my $ktype = whatIsInput($k);
365	# my $vtype = whatIsOutput($v, WANT_EXT\|WANT_UNDEF) ;
366	#
367	# if ($ktype ne 'filename')
368	# {
369	# return $self->saveErrorString("hash key not filename") ;
370	# }
371	#
372	# my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
373	# if (! $valid{$vtype})
374	# {
375	# return $self->saveErrorString("hash value not ok") ;
376	# }
377	# }
378	#
379	# return $self ;
380	#}
381
382	sub createSelfTiedObject
383	{
384	my $class = shift \|\| (caller)[0] ;
385	my $error_ref = shift ;
386
387	my $obj = bless Symbol::gensym(), ref($class) \|\| $class;
388	tie *$obj, $obj if $] >= 5.005;
389	*$obj->{Closed} = 1 ;
390	$$error_ref = '';
391	*$obj->{Error} = $error_ref ;
392	my $errno = 0 ;
393	*$obj->{ErrorNo} = \$errno ;
394
395	return $obj;
396	}
397
398
399
400	#package Parse::Parameters ;
401	#
402	#
403	#require Exporter;
404	#our ($VERSION, @ISA, @EXPORT);
405	#$VERSION = '2.000_08';
406	#@ISA = qw(Exporter);
407
408	$EXPORT_TAGS{Parse} = [qw( ParseParameters
409	Parse_any Parse_unsigned Parse_signed
410	Parse_boolean Parse_custom Parse_string
411	Parse_store_ref
412	)
413	];
414
415	push @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
416
417	use constant Parse_any => 0x01;
418	use constant Parse_unsigned => 0x02;
419	use constant Parse_signed => 0x04;
420	use constant Parse_boolean => 0x08;
421	use constant Parse_string => 0x10;
422	use constant Parse_custom => 0x12;
423
424	use constant Parse_store_ref => 0x100 ;
425
426	use constant OFF_PARSED => 0 ;
427	use constant OFF_TYPE => 1 ;
428	use constant OFF_DEFAULT => 2 ;
429	use constant OFF_FIXED => 3 ;
430	use constant OFF_FIRST_ONLY => 4 ;
431	use constant OFF_STICKY => 5 ;
432
433
434
435	sub ParseParameters
436	{
437	my $level = shift \|\| 0 ;
438
439	my $sub = (caller($level + 1))[3] ;
440	local $Carp::CarpLevel = 1 ;
441	my $p = new IO::Compress::Base::Parameters() ;
442	$p->parse(@_)
443	or croak "$sub: $p->{Error}" ;
444
445	return $p;
446	}
447
448	#package IO::Compress::Base::Parameters;
449
450	use strict;
451	use warnings;
452	use Carp;
453
454	sub IO::Compress::Base::Parameters::new
455	{
456	my $class = shift ;
457
458	my $obj = { Error => '',
459	Got => {},
460	} ;
461
462	#return bless $obj, ref($class) \|\| $class \|\| __PACKAGE__ ;
463	return bless $obj, 'IO::Compress::Base::Parameters' ;
464	}
465
466	sub IO::Compress::Base::Parameters::setError
467	{
468	my $self = shift ;
469	my $error = shift ;
470	my $retval = @_ ? shift : undef ;
471
472	$self->{Error} = $error ;
473	return $retval;
474	}
475
476	#sub getError
477	#{
478	# my $self = shift ;
479	# return $self->{Error} ;
480	#}
481
482	sub IO::Compress::Base::Parameters::parse
483	{
484	my $self = shift ;
485
486	my $default = shift ;
487
488	my $got = $self->{Got} ;
489	my $firstTime = keys %{ $got } == 0 ;
490
491	my (@Bad) ;
492	my @entered = () ;
493
494	# Allow the options to be passed as a hash reference or
495	# as the complete hash.
496	if (@_ == 0) {
497	@entered = () ;
498	}
499	elsif (@_ == 1) {
500	my $href = $_[0] ;
501	return $self->setError("Expected even number of parameters, got 1")
502	if ! defined $href or ! ref $href or ref $href ne "HASH" ;
503
504	foreach my $key (keys %$href) {
505	push @entered, $key ;
506	push @entered, \$href->{$key} ;
507	}
508	}
509	else {
510	my $count = @_;
511	return $self->setError("Expected even number of parameters, got $count")
512	if $count % 2 != 0 ;
513
514	for my $i (0.. $count / 2 - 1) {
515	push @entered, $_[2* $i] ;
516	push @entered, \$_[2* $i+1] ;
517	}
518	}
519
520
521	while (my ($key, $v) = each %$default)
522	{
523	croak "need 4 params [@$v]"
524	if @$v != 4 ;
525
526	my ($first_only, $sticky, $type, $value) = @$v ;
527	my $x ;
528	$self->_checkType($key, \$value, $type, 0, \$x)
529	or return undef ;
530
531	$key = lc $key;
532
533	if ($firstTime \|\| ! $sticky) {
534	$got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
535	}
536
537	$got->{$key}[OFF_PARSED] = 0 ;
538	}
539
540	for my $i (0.. @entered / 2 - 1) {
541	my $key = $entered[2* $i] ;
542	my $value = $entered[2* $i+1] ;
543
544	#print "Key [$key] Value [$value]" ;
545	#print defined $$value ? "[$$value]\n" : "[undef]\n";
546
547	$key =~ s/^-// ;
548	my $canonkey = lc $key;
549
550	if ($got->{$canonkey} && ($firstTime \|\|
551	! $got->{$canonkey}[OFF_FIRST_ONLY] ))
552	{
553	my $type = $got->{$canonkey}[OFF_TYPE] ;
554	my $s ;
555	$self->_checkType($key, $value, $type, 1, \$s)
556	or return undef ;
557	#$value = $$value unless $type & Parse_store_ref ;
558	$value = $$value ;
559	$got->{$canonkey} = [1, $type, $value, $s] ;
560	}
561	else
562	{ push (@Bad, $key) }
563	}
564
565	if (@Bad) {
566	my ($bad) = join(", ", @Bad) ;
567	return $self->setError("unknown key value(s) @Bad") ;
568	}
569
570	return 1;
571	}
572
573	sub IO::Compress::Base::Parameters::_checkType
574	{
575	my $self = shift ;
576
577	my $key = shift ;
578	my $value = shift ;
579	my $type = shift ;
580	my $validate = shift ;
581	my $output = shift;
582
583	#local $Carp::CarpLevel = $level ;
584	#print "PARSE $type $key $value $validate $sub\n" ;
585	if ( $type & Parse_store_ref)
586	{
587	#$value = $$value
588	# if ref ${ $value } ;
589
590	$$output = $value ;
591	return 1;
592	}
593
594	$value = $$value ;
595
596	if ($type & Parse_any)
597	{
598	$$output = $value ;
599	return 1;
600	}
601	elsif ($type & Parse_unsigned)
602	{
603	return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
604	if $validate && ! defined $value ;
605	return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
606	if $validate && $value !~ /^\d+$/;
607
608	$$output = defined $value ? $value : 0 ;
609	return 1;
610	}
611	elsif ($type & Parse_signed)
612	{
613	return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
614	if $validate && ! defined $value ;
615	return $self->setError("Parameter '$key' must be a signed int, got '$value'")
616	if $validate && $value !~ /^-?\d+$/;
617
618	$$output = defined $value ? $value : 0 ;
619	return 1 ;
620	}
621	elsif ($type & Parse_boolean)
622	{
623	return $self->setError("Parameter '$key' must be an int, got '$value'")
624	if $validate && defined $value && $value !~ /^\d*$/;
625	$$output = defined $value ? $value != 0 : 0 ;
626	return 1;
627	}
628	elsif ($type & Parse_string)
629	{
630	$$output = defined $value ? $value : "" ;
631	return 1;
632	}
633
634	$$output = $value ;
635	return 1;
636	}
637
638
639
640	sub IO::Compress::Base::Parameters::parsed
641	{
642	my $self = shift ;
643	my $name = shift ;
644
645	return $self->{Got}{lc $name}[OFF_PARSED] ;
646	}
647
648	sub IO::Compress::Base::Parameters::value
649	{
650	my $self = shift ;
651	my $name = shift ;
652
653	if (@_)
654	{
655	$self->{Got}{lc $name}[OFF_PARSED] = 1;
656	$self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
657	$self->{Got}{lc $name}[OFF_FIXED] = $_[0] ;
658	}
659
660	return $self->{Got}{lc $name}[OFF_FIXED] ;
661	}
662
663	sub IO::Compress::Base::Parameters::valueOrDefault
664	{
665	my $self = shift ;
666	my $name = shift ;
667	my $default = shift ;
668
669	my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
670
671	return $value if defined $value ;
672	return $default ;
673	}
674
675	sub IO::Compress::Base::Parameters::wantValue
676	{
677	my $self = shift ;
678	my $name = shift ;
679
680	return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
681
682	}
683
684	sub IO::Compress::Base::Parameters::clone
685	{
686	my $self = shift ;
687	my $obj = { };
688	my %got ;
689
690	while (my ($k, $v) = each %{ $self->{Got} }) {
691	$got{$k} = [ @$v ];
692	}
693
694	$obj->{Error} = $self->{Error};
695	$obj->{Got} = \%got ;
696
697	return bless $obj, 'IO::Compress::Base::Parameters' ;
698	}
699
700	package IO::Compress::Base::Common;
701
702	1;