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