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