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

package Compress::Zlib::Common;

use strict ;
use warnings;
use bytes;

use Carp;
use Scalar::Util qw(blessed readonly);
use File::GlobMapper;

require Exporter;
our ($VERSION, @ISA, @EXPORT);
@ISA = qw(Exporter);
$VERSION = '2.000_05';

@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput ckInputParam 
              isaFileGlobString cleanFileGlobString oneTarget
              setBinModeInput setBinModeOutput
              ckOutputParam ckInOutParams 
              WANT_CODE
              WANT_EXT
              WANT_UNDEF
              WANT_HASH
          );  

our ($wantBinmode);
$wantBinmode = ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} ')
                    ? 1 : 0 ;

sub setBinModeInput($$)
{
    my $handle = shift ;
    my $want   = defined $_[0] ? shift : $wantBinmode ;

    binmode $handle 
        if  $want;
}

sub setBinModeOutput($$)
{
    my $handle = shift ;
    my $want   = defined $_[0] ? shift : $wantBinmode ;

    binmode $handle 
        if  $want;
}

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 ;

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 ckInputParam ($$$;$)
{
    my $from = shift ;
    my $inType = whatIsInput($_[0], $_[2]);
    local $Carp::CarpLevel = 1;

    croak "$from: input parameter not a filename, filehandle, array ref or scalar ref"
        if ! $inType ;

    if ($inType  eq 'filename' )
    {
        croak "$from: input filename is undef or null string"
            if ! defined $_[0] || $_[0] eq ''  ;

        if ($_[0] ne '-' && ! -e $_[0] )
        {
            ${$_[1]} = "input file '$_[0]' does not exist";
            return undef;
        }
    }

    return 1;
}

sub ckOutputParam ($$$)
{
    my $from = shift ;
    my $outType = whatIsOutput($_[0]);
    local $Carp::CarpLevel = 1;

    croak "$from: output parameter not a filename, filehandle or scalar ref"
        if ! $outType ;

    croak "$from: output filename is undef or null string"
        if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '')  ;

    croak("$from: output buffer is read-only")
        if $outType eq 'buffer' && readonly(${ $_[0] });
    
    return 1;    
}

sub Validator::new
{
    my $class = shift ;

    my $Class = shift ;
    my $type = shift ;
    my $error_ref = shift ;
    my $reportClass = shift ;

    my %data = (Class       => $Class, 
                Type        => $type,
                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)
    {
        croak "$reportClass: illegal input parameter" ;
        #return undef ;
    }    

    if ($inType eq 'hash')
    {
        $obj->{Hash} = 1 ;
        $obj->{oneInput} = 1 ;
        return $obj->validateHash($_[0]);
    }

    if (! $outType)
    {
        croak "$reportClass: illegal output parameter" ;
        #return undef ;
    }    


    if ($inType ne 'fileglob' && $outType eq 'fileglob')
    {
        ${ $data{Error} } = "Need input fileglob for outout fileglob";
        return undef ;
    }    

    if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
    {
        ${ $data{Error} } = "input must ne filename or fileglob when output is a hash";
        return undef ;
    }    

    if ($inType eq 'fileglob' && $outType eq 'fileglob')
    {
        $data{GlobMap} = 1 ;
        $data{inType} = $data{outType} = 'filename';
        my $mapper = new File::GlobMapper($_[0], $_[1]);
        if ( ! $mapper )
        {
            ${ $data{Error} } = $File::GlobMapper::Error ;
            return undef ;
        }
        $data{Pairs} = $mapper->getFileMap();

        return $obj;
    }
    
    croak("$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)
        {
            # legal or die?
            die "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')
    {
        $obj->validateInputArray($_[0])
            or return undef ;
    }

    croak("$reportClass: output buffer is read-only")
        if $outType eq 'buffer' && Compress::Zlib::_readonly_ref($_[1]);

    if ($outType eq 'filename' )
    {
        croak "$reportClass: output filename is undef or null string"
            if ! defined $_[1] || $_[1] eq ''  ;
    }
    
    return $obj ;
}


sub Validator::validateInputFilenames
{
    my $self = shift ;

    foreach my $filename (@_)
    {
        croak "$self->{reportClass}: input filename is undef or null string"
            if ! defined $filename || $filename eq ''  ;

        next if $filename eq '-';

        if (! -e $filename )
        {
            ${ $self->{Error} } = "input file '$filename' does not exist";
            return undef;
        }

        if (! -r $filename )
        {
            ${ $self->{Error} } = "cannot open file '$filename': $!";
            return undef;
        }
    }

    return 1 ;
}

sub Validator::validateInputArray
{
    my $self = shift ;

    foreach my $element ( @{ $_[0] } )
    {
        my $inType  = whatIsInput($element);
    
        if (! $inType)
        {
            ${ $self->{Error} } = "unknown input parameter" ;
            return undef ;
        }    
    }

    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')
        {
            ${ $self->{Error} } = "hash key not filename" ;
            return undef ;
        }    

        my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
        if (! $valid{$vtype})
        {
            ${ $self->{Error} } = "hash value not ok" ;
            return undef ;
        }    
    }

    return $self ;
}

1;
Commit	Line	Data
642e522c	1	package Compress::Zlib::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);
	13	@ISA = qw(Exporter);
	14	$VERSION = '2.000_05';
	15
	16	@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput ckInputParam
	17	isaFileGlobString cleanFileGlobString oneTarget
	18	setBinModeInput setBinModeOutput
	19	ckOutputParam ckInOutParams
	20	WANT_CODE
	21	WANT_EXT
	22	WANT_UNDEF
	23	WANT_HASH
	24	);
	25
07a53161	26	our ($wantBinmode);
	27	$wantBinmode = ($] >= 5.006 && eval ' ${^UNICODE} \|\| ${^UTF8LOCALE} ')
	28	? 1 : 0 ;
	29
	30	sub setBinModeInput($$)
642e522c	31	{
642e522c	32	my $handle = shift ;
07a53161	33	my $want = defined $_[0] ? shift : $wantBinmode ;
642e522c	34
0e28d6a3	35	binmode $handle
07a53161	36	if $want;
642e522c	37	}
642e522c	38
07a53161	39	sub setBinModeOutput($$)
642e522c	40	{
642e522c	41	my $handle = shift ;
07a53161	42	my $want = defined $_[0] ? shift : $wantBinmode ;
642e522c	43
0e28d6a3	44	binmode $handle
07a53161	45	if $want;
642e522c	46	}
642e522c	47
642e522c	48	sub isaFilehandle($)
	49	{
	50	use utf8; # Pragma needed to keep Perl 5.6.0 happy
	51	return (defined $_[0] and
	52	(UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa(\$_[0],'GLOB'))
	53	and defined fileno($_[0]) )
	54	}
	55
	56	sub isaFilename($)
	57	{
	58	return (defined $_[0] and
	59	! ref $_[0] and
	60	UNIVERSAL::isa(\$_[0], 'SCALAR'));
	61	}
	62
	63	sub isaFileGlobString
	64	{
	65	return defined $_[0] && $_[0] =~ /^<.*>$/;
	66	}
	67
	68	sub cleanFileGlobString
	69	{
	70	my $string = shift ;
	71
	72	$string =~ s/^\s<\s(.)\s>\s*$/$1/;
	73
	74	return $string;
	75	}
	76
	77	use constant WANT_CODE => 1 ;
	78	use constant WANT_EXT => 2 ;
	79	use constant WANT_UNDEF => 4 ;
	80	use constant WANT_HASH => 8 ;
	81
	82	sub whatIsInput($;$)
	83	{
	84	my $got = whatIs(@_);
07a53161	85
642e522c	86	if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
	87	{
	88	use IO::File;
	89	$got = 'handle';
	90	#$_[0] = \*STDIN;
	91	$_[0] = new IO::File("<-");
	92	}
	93
	94	return $got;
	95	}
	96
	97	sub whatIsOutput($;$)
	98	{
	99	my $got = whatIs(@_);
07a53161	100
642e522c	101	if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
	102	{
	103	$got = 'handle';
	104	#$_[0] = \*STDOUT;
	105	$_[0] = new IO::File(">-");
	106	}
	107
	108	return $got;
	109	}
	110
	111	sub whatIs ($;$)
	112	{
	113	return 'handle' if isaFilehandle($_[0]);
	114
	115	my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
	116	my $extended = defined $_[1] && $_[1] & WANT_EXT ;
	117	my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
	118	my $hash = defined $_[1] && $_[1] & WANT_HASH ;
	119
	120	return 'undef' if ! defined $_[0] && $undef ;
	121
	122	if (ref $_[0]) {
	123	return '' if blessed($_[0]); # is an object
	124	#return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
	125	return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
	126	return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
	127	return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
	128	return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
	129	return '';
	130	}
	131
	132	return 'fileglob' if $extended && isaFileGlobString($_[0]);
	133	return 'filename';
	134	}
	135
	136	sub oneTarget
	137	{
	138	return $_[0] =~ /^(code\|handle\|buffer\|filename)$/;
	139	}
	140
	141	sub ckInputParam ($$$;$)
	142	{
	143	my $from = shift ;
	144	my $inType = whatIsInput($_[0], $_[2]);
	145	local $Carp::CarpLevel = 1;
	146
	147	croak "$from: input parameter not a filename, filehandle, array ref or scalar ref"
	148	if ! $inType ;
	149
	150	if ($inType eq 'filename' )
	151	{
	152	croak "$from: input filename is undef or null string"
	153	if ! defined $_[0] \|\| $_[0] eq '' ;
	154
	155	if ($_[0] ne '-' && ! -e $_[0] )
	156	{
	157	${$_[1]} = "input file '$_[0]' does not exist";
	158	return undef;
	159	}
	160	}
	161
	162	return 1;
	163	}
	164
165	sub ckOutputParam ($$$)
166	{
167	my $from = shift ;
168	my $outType = whatIsOutput($_[0]);
169	local $Carp::CarpLevel = 1;
170
171	croak "$from: output parameter not a filename, filehandle or scalar ref"
172	if ! $outType ;
173
174	croak "$from: output filename is undef or null string"
175	if $outType eq 'filename' && (! defined $_[0] \|\| $_[0] eq '') ;
176
177	croak("$from: output buffer is read-only")
178	if $outType eq 'buffer' && readonly(${ $_[0] });
179
180	return 1;
181	}
182
642e522c	183	sub Validator::new
	184	{
	185	my $class = shift ;
	186
	187	my $Class = shift ;
	188	my $type = shift ;
	189	my $error_ref = shift ;
	190	my $reportClass = shift ;
	191
	192	my %data = (Class => $Class,
	193	Type => $type,
	194	Error => $error_ref,
	195	reportClass => $reportClass,
	196	) ;
	197
	198	my $obj = bless \%data, $class ;
	199
	200	local $Carp::CarpLevel = 1;
	201
	202	my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT\|WANT_HASH);
	203	my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT\|WANT_HASH);
	204
	205	my $oneInput = $data{oneInput} = oneTarget($inType);
	206	my $oneOutput = $data{oneOutput} = oneTarget($outType);
	207
	208	if (! $inType)
	209	{
	210	croak "$reportClass: illegal input parameter" ;
	211	#return undef ;
	212	}
	213
	214	if ($inType eq 'hash')
	215	{
	216	$obj->{Hash} = 1 ;
	217	$obj->{oneInput} = 1 ;
	218	return $obj->validateHash($_[0]);
	219	}
	220
	221	if (! $outType)
	222	{
	223	croak "$reportClass: illegal output parameter" ;
	224	#return undef ;
	225	}
	226
	227
	228	if ($inType ne 'fileglob' && $outType eq 'fileglob')
	229	{
	230	${ $data{Error} } = "Need input fileglob for outout fileglob";
	231	return undef ;
	232	}
	233
	234	if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
	235	{
	236	${ $data{Error} } = "input must ne filename or fileglob when output is a hash";
	237	return undef ;
	238	}
	239
	240	if ($inType eq 'fileglob' && $outType eq 'fileglob')
	241	{
	242	$data{GlobMap} = 1 ;
	243	$data{inType} = $data{outType} = 'filename';
	244	my $mapper = new File::GlobMapper($_[0], $_[1]);
	245	if ( ! $mapper )
	246	{
247	${ $data{Error} } = $File::GlobMapper::Error ;
248	return undef ;
249	}
250	$data{Pairs} = $mapper->getFileMap();
251
252	return $obj;
253	}
254
255	croak("$reportClass: input and output $inType are identical")
256	if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
257
258	if ($inType eq 'fileglob') # && $outType ne 'fileglob'
259	{
260	my $glob = cleanFileGlobString($_[0]);
261	my @inputs = glob($glob);
262
263	if (@inputs == 0)
264	{
265	# legal or die?
266	die "legal or die???" ;
267	}
268	elsif (@inputs == 1)
269	{
270	$obj->validateInputFilenames($inputs[0])
271	or return undef;
272	$_[0] = $inputs[0] ;
273	$data{inType} = 'filename' ;
274	$data{oneInput} = 1;
275	}
276	else
277	{
278	$obj->validateInputFilenames(@inputs)
279	or return undef;
280	$_[0] = [ @inputs ] ;
281	$data{inType} = 'filenames' ;
282	}
283	}
284	elsif ($inType eq 'filename')
285	{
286	$obj->validateInputFilenames($_[0])
287	or return undef;
288	}
289	elsif ($inType eq 'array')
290	{
291	$obj->validateInputArray($_[0])
292	or return undef ;
293	}
294
295	croak("$reportClass: output buffer is read-only")
296	if $outType eq 'buffer' && Compress::Zlib::_readonly_ref($_[1]);
297
298	if ($outType eq 'filename' )
299	{
300	croak "$reportClass: output filename is undef or null string"
301	if ! defined $_[1] \|\| $_[1] eq '' ;
302	}
303
304	return $obj ;
305	}
306
307
308	sub Validator::validateInputFilenames
309	{
310	my $self = shift ;
311
312	foreach my $filename (@_)
313	{
314	croak "$self->{reportClass}: input filename is undef or null string"
315	if ! defined $filename \|\| $filename eq '' ;
316
317	next if $filename eq '-';
318
319	if (! -e $filename )
320	{
321	${ $self->{Error} } = "input file '$filename' does not exist";
322	return undef;
323	}
324
325	if (! -r $filename )
326	{
327	${ $self->{Error} } = "cannot open file '$filename': $!";
328	return undef;
329	}
330	}
331
332	return 1 ;
333	}
334
335	sub Validator::validateInputArray
336	{
337	my $self = shift ;
338
339	foreach my $element ( @{ $_[0] } )
340	{
341	my $inType = whatIsInput($element);
342
343	if (! $inType)
344	{
345	${ $self->{Error} } = "unknown input parameter" ;
346	return undef ;
347	}
348	}
349
350	return 1 ;
351	}
352
353	sub Validator::validateHash
354	{
355	my $self = shift ;
356	my $href = shift ;
357
358	while (my($k, $v) = each %$href)
359	{
360	my $ktype = whatIsInput($k);
361	my $vtype = whatIsOutput($v, WANT_EXT\|WANT_UNDEF) ;
362
363	if ($ktype ne 'filename')
364	{
365	${ $self->{Error} } = "hash key not filename" ;
366	return undef ;
367	}
368
369	my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
370	if (! $valid{$vtype})
371	{
372	${ $self->{Error} } = "hash value not ok" ;
373	return undef ;
374	}
375	}
376
377	return $self ;
378	}
379
380	1;