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