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