[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, %EXPORT_TAGS);
@ISA = qw(Exporter);
$VERSION = '2.000_07';

@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_ERROR
          );  

%EXPORT_TAGS = ( Status => [qw( STATUS_OK
                                 STATUS_ENDSTREAM
                                 STATUS_ERROR
                           )]);

                       
use constant STATUS_OK        => 0;
use constant STATUS_ENDSTREAM => 1;
use constant STATUS_ERROR     => 2;
          
our ($needBinmode);
$needBinmode = ($^O eq 'MSWin32' || 
                    ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
                    ? 1 : 0 ;

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;
}


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