ext/Compress/Zlib/lib/Compress/Zlib/Common.pm

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