[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
          );  

sub setBinModeInput($)
{
    my $handle = shift ;

    binmode $handle unless $^O eq 'MSWin32' ;
    #binmode $handle if $] == 5.008 ;
    #binmode $handle unless isSTDIN($handle) ;
}

sub setBinModeOutput($)
{
    my $handle = shift ;

    #binmode $handle if $] == 5.008;
    #binmode $handle unless isSTDOUT($handle) ;
}

#sub isSTDIO($)
#{
#    my $handle = shift ;
#
#    return 0 unless isaFilehandle($handle);
#    return fileno $handle == fileno STDIN || fileno $handle == fileno STDOUT;
#}
#
#sub isSTDIN($)
#{
#    my $handle = shift ;
#
#    return 0 unless isaFilehandle($handle);
#    return fileno $handle == fileno STDIN;
#}
#
#sub isSTDOUT($)
#{
#    my $handle = shift ;
#
#    return 0 unless isaFilehandle($handle);
#    return fileno $handle == fileno STDOUT;
#}

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