ext/Compress/IO/Base/lib/IO/Compress/Base/Common.pm

   1 package IO::Compress::Base::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_12';
  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_EOF
  30               STATUS_ERROR
  31           );
  32
  33 %EXPORT_TAGS = ( Status => [qw( STATUS_OK
  34                                  STATUS_ENDSTREAM
  35                                  STATUS_EOF
  36                                  STATUS_ERROR
  37                            )]);
  38
  39
  40 use constant STATUS_OK        => 0;
  41 use constant STATUS_ENDSTREAM => 1;
  42 use constant STATUS_EOF       => 2;
  43 use constant STATUS_ERROR     => -1;
  44 #use constant STATUS_OK        =>  0;
  45 #use constant STATUS_ENDSTREAM =>  1;
  46 #use constant STATUS_ERROR     =>  2;
  47 #use constant STATUS_EOF       =>  3;
  48
  49 our ($needBinmode);
  50 $needBinmode = ($^O eq 'MSWin32' ||
  51                     ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
  52                     ? 1 : 1 ;
  53
  54 sub setBinModeInput($)
  55 {
  56     my $handle = shift ;
  57
  58     binmode $handle
  59         if  $needBinmode;
  60 }
  61
  62 sub setBinModeOutput($)
  63 {
  64     my $handle = shift ;
  65
  66     binmode $handle
  67         if  $needBinmode;
  68 }
  69
  70 sub isaFilehandle($)
  71 {
  72     use utf8; # Pragma needed to keep Perl 5.6.0 happy
  73     return (defined $_[0] and
  74              (UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa(\$_[0],'GLOB'))
  75                  and defined fileno($_[0])  )
  76 }
  77
  78 sub isaFilename($)
  79 {
  80     return (defined $_[0] and
  81            ! ref $_[0]    and
  82            UNIVERSAL::isa(\$_[0], 'SCALAR'));
  83 }
  84
  85 sub isaFileGlobString
  86 {
  87     return defined $_[0] && $_[0] =~ /^<.*>$/;
  88 }
  89
  90 sub cleanFileGlobString
  91 {
  92     my $string = shift ;
  93
  94     $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
  95
  96     return $string;
  97 }
  98
  99 use constant WANT_CODE  => 1 ;
 100 use constant WANT_EXT   => 2 ;
 101 use constant WANT_UNDEF => 4 ;
 102 #use constant WANT_HASH  => 8 ;
 103 use constant WANT_HASH  => 0 ;
 104
 105 sub whatIsInput($;$)
 106 {
 107     my $got = whatIs(@_);
 108
 109     if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
 110     {
 111         use IO::File;
 112         $got = 'handle';
 113         #$_[0] = \*STDIN;
 114         $_[0] = new IO::File("<-");
 115     }
 116
 117     return $got;
 118 }
 119
 120 sub whatIsOutput($;$)
 121 {
 122     my $got = whatIs(@_);
 123
 124     if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
 125     {
 126         $got = 'handle';
 127         #$_[0] = \*STDOUT;
 128         $_[0] = new IO::File(">-");
 129     }
 130
 131     return $got;
 132 }
 133
 134 sub whatIs ($;$)
 135 {
 136     return 'handle' if isaFilehandle($_[0]);
 137
 138     my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
 139     my $extended = defined $_[1] && $_[1] & WANT_EXT ;
 140     my $undef    = defined $_[1] && $_[1] & WANT_UNDEF ;
 141     my $hash     = defined $_[1] && $_[1] & WANT_HASH ;
 142
 143     return 'undef'  if ! defined $_[0] && $undef ;
 144
 145     if (ref $_[0]) {
 146         return ''       if blessed($_[0]); # is an object
 147         #return ''       if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
 148         return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
 149         return 'array'  if UNIVERSAL::isa($_[0], 'ARRAY')  && $extended ;
 150         return 'hash'   if UNIVERSAL::isa($_[0], 'HASH')   && $hash ;
 151         return 'code'   if UNIVERSAL::isa($_[0], 'CODE')   && $wantCode ;
 152         return '';
 153     }
 154
 155     return 'fileglob' if $extended && isaFileGlobString($_[0]);
 156     return 'filename';
 157 }
 158
 159 sub oneTarget
 160 {
 161     return $_[0] =~ /^(code|handle|buffer|filename)$/;
 162 }
 163
 164 sub Validator::new
 165 {
 166     my $class = shift ;
 167
 168     my $Class = shift ;
 169     my $error_ref = shift ;
 170     my $reportClass = shift ;
 171
 172     my %data = (Class       => $Class,
 173                 Error       => $error_ref,
 174                 reportClass => $reportClass,
 175                ) ;
 176
 177     my $obj = bless \%data, $class ;
 178
 179     local $Carp::CarpLevel = 1;
 180
 181     my $inType    = $data{inType}    = whatIsInput($_[0], WANT_EXT|WANT_HASH);
 182     my $outType   = $data{outType}   = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
 183
 184     my $oneInput  = $data{oneInput}  = oneTarget($inType);
 185     my $oneOutput = $data{oneOutput} = oneTarget($outType);
 186
 187     if (! $inType)
 188     {
 189         $obj->croakError("$reportClass: illegal input parameter") ;
 190         #return undef ;
 191     }
 192
 193 #    if ($inType eq 'hash')
 194 #    {
 195 #        $obj->{Hash} = 1 ;
 196 #        $obj->{oneInput} = 1 ;
 197 #        return $obj->validateHash($_[0]);
 198 #    }
 199
 200     if (! $outType)
 201     {
 202         $obj->croakError("$reportClass: illegal output parameter") ;
 203         #return undef ;
 204     }
 205
 206
 207     if ($inType ne 'fileglob' && $outType eq 'fileglob')
 208     {
 209         $obj->croakError("Need input fileglob for outout fileglob");
 210     }
 211
 212 #    if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
 213 #    {
 214 #        $obj->croakError("input must ne filename or fileglob when output is a hash");
 215 #    }
 216
 217     if ($inType eq 'fileglob' && $outType eq 'fileglob')
 218     {
 219         $data{GlobMap} = 1 ;
 220         $data{inType} = $data{outType} = 'filename';
 221         my $mapper = new File::GlobMapper($_[0], $_[1]);
 222         if ( ! $mapper )
 223         {
 224             return $obj->saveErrorString($File::GlobMapper::Error) ;
 225         }
 226         $data{Pairs} = $mapper->getFileMap();
 227
 228         return $obj;
 229     }
 230
 231     $obj->croakError("$reportClass: input and output $inType are identical")
 232         if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
 233
 234     if ($inType eq 'fileglob') # && $outType ne 'fileglob'
 235     {
 236         my $glob = cleanFileGlobString($_[0]);
 237         my @inputs = glob($glob);
 238
 239         if (@inputs == 0)
 240         {
 241             # TODO -- legal or die?
 242             die "globmap matched zero file -- legal or die???" ;
 243         }
 244         elsif (@inputs == 1)
 245         {
 246             $obj->validateInputFilenames($inputs[0])
 247                 or return undef;
 248             $_[0] = $inputs[0]  ;
 249             $data{inType} = 'filename' ;
 250             $data{oneInput} = 1;
 251         }
 252         else
 253         {
 254             $obj->validateInputFilenames(@inputs)
 255                 or return undef;
 256             $_[0] = [ @inputs ] ;
 257             $data{inType} = 'filenames' ;
 258         }
 259     }
 260     elsif ($inType eq 'filename')
 261     {
 262         $obj->validateInputFilenames($_[0])
 263             or return undef;
 264     }
 265     elsif ($inType eq 'array')
 266     {
 267         $data{inType} = 'filenames' ;
 268         $obj->validateInputArray($_[0])
 269             or return undef ;
 270     }
 271
 272     return $obj->saveErrorString("$reportClass: output buffer is read-only")
 273         if $outType eq 'buffer' && readonly(${ $_[1] });
 274
 275     if ($outType eq 'filename' )
 276     {
 277         $obj->croakError("$reportClass: output filename is undef or null string")
 278             if ! defined $_[1] || $_[1] eq ''  ;
 279     }
 280
 281     return $obj ;
 282 }
 283
 284 sub Validator::saveErrorString
 285 {
 286     my $self   = shift ;
 287     ${ $self->{Error} } = shift ;
 288     return undef;
 289
 290 }
 291
 292 sub Validator::croakError
 293 {
 294     my $self   = shift ;
 295     $self->saveErrorString($_[0]);
 296     croak $_[0];
 297 }
 298
 299
 300
 301 sub Validator::validateInputFilenames
 302 {
 303     my $self = shift ;
 304
 305     foreach my $filename (@_)
 306     {
 307         $self->croakError("$self->{reportClass}: input filename is undef or null string")
 308             if ! defined $filename || $filename eq ''  ;
 309
 310         next if $filename eq '-';
 311
 312         if (! -e $filename )
 313         {
 314             return $self->saveErrorString("input file '$filename' does not exist");
 315         }
 316
 317         if (! -r $filename )
 318         {
 319             return $self->saveErrorString("cannot open file '$filename': $!");
 320         }
 321     }
 322
 323     return 1 ;
 324 }
 325
 326 sub Validator::validateInputArray
 327 {
 328     my $self = shift ;
 329
 330     if ( @{ $_[0] } == 0 )
 331     {
 332         return $self->saveErrorString("empty array reference") ;
 333     }
 334
 335     foreach my $element ( @{ $_[0] } )
 336     {
 337         my $inType  = whatIsInput($element);
 338
 339         if (! $inType)
 340         {
 341             $self->croakError("unknown input parameter") ;
 342         }
 343         elsif($inType eq 'filename')
 344         {
 345             $self->validateInputFilenames($element)
 346                 or return undef ;
 347         }
 348         else
 349         {
 350             $self->croakError("not a filename") ;
 351         }
 352     }
 353
 354     return 1 ;
 355 }
 356
 357 #sub Validator::validateHash
 358 #{
 359 #    my $self = shift ;
 360 #    my $href = shift ;
 361 #
 362 #    while (my($k, $v) = each %$href)
 363 #    {
 364 #        my $ktype = whatIsInput($k);
 365 #        my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
 366 #
 367 #        if ($ktype ne 'filename')
 368 #        {
 369 #            return $self->saveErrorString("hash key not filename") ;
 370 #        }
 371 #
 372 #        my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
 373 #        if (! $valid{$vtype})
 374 #        {
 375 #            return $self->saveErrorString("hash value not ok") ;
 376 #        }
 377 #    }
 378 #
 379 #    return $self ;
 380 #}
 381
 382 sub createSelfTiedObject
 383 {
 384     my $class = shift || (caller)[0] ;
 385     my $error_ref = shift ;
 386
 387     my $obj = bless Symbol::gensym(), ref($class) || $class;
 388     tie *$obj, $obj if $] >= 5.005;
 389     *$obj->{Closed} = 1 ;
 390     $$error_ref = '';
 391     *$obj->{Error} = $error_ref ;
 392     my $errno = 0 ;
 393     *$obj->{ErrorNo} = \$errno ;
 394
 395     return $obj;
 396 }
 397
 398
 399
 400 #package Parse::Parameters ;
 401 #
 402 #
 403 #require Exporter;
 404 #our ($VERSION, @ISA, @EXPORT);
 405 #$VERSION = '2.000_08';
 406 #@ISA = qw(Exporter);
 407
 408 $EXPORT_TAGS{Parse} = [qw( ParseParameters
 409                            Parse_any Parse_unsigned Parse_signed
 410                            Parse_boolean Parse_custom Parse_string
 411                            Parse_store_ref
 412                          )
 413                       ];
 414
 415 push @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
 416
 417 use constant Parse_any      => 0x01;
 418 use constant Parse_unsigned => 0x02;
 419 use constant Parse_signed   => 0x04;
 420 use constant Parse_boolean  => 0x08;
 421 use constant Parse_string   => 0x10;
 422 use constant Parse_custom   => 0x12;
 423
 424 use constant Parse_store_ref => 0x100 ;
 425
 426 use constant OFF_PARSED     => 0 ;
 427 use constant OFF_TYPE       => 1 ;
 428 use constant OFF_DEFAULT    => 2 ;
 429 use constant OFF_FIXED      => 3 ;
 430 use constant OFF_FIRST_ONLY => 4 ;
 431 use constant OFF_STICKY     => 5 ;
 432
 433
 434
 435 sub ParseParameters
 436 {
 437     my $level = shift || 0 ;
 438
 439     my $sub = (caller($level + 1))[3] ;
 440     local $Carp::CarpLevel = 1 ;
 441     my $p = new IO::Compress::Base::Parameters() ;
 442     $p->parse(@_)
 443         or croak "$sub: $p->{Error}" ;
 444
 445     return $p;
 446 }
 447
 448 #package IO::Compress::Base::Parameters;
 449
 450 use strict;
 451 use warnings;
 452 use Carp;
 453
 454 sub IO::Compress::Base::Parameters::new
 455 {
 456     my $class = shift ;
 457
 458     my $obj = { Error => '',
 459                 Got   => {},
 460               } ;
 461
 462     #return bless $obj, ref($class) || $class || __PACKAGE__ ;
 463     return bless $obj, 'IO::Compress::Base::Parameters' ;
 464 }
 465
 466 sub IO::Compress::Base::Parameters::setError
 467 {
 468     my $self = shift ;
 469     my $error = shift ;
 470     my $retval = @_ ? shift : undef ;
 471
 472     $self->{Error} = $error ;
 473     return $retval;
 474 }
 475
 476 #sub getError
 477 #{
 478 #    my $self = shift ;
 479 #    return $self->{Error} ;
 480 #}
 481
 482 sub IO::Compress::Base::Parameters::parse
 483 {
 484     my $self = shift ;
 485
 486     my $default = shift ;
 487
 488     my $got = $self->{Got} ;
 489     my $firstTime = keys %{ $got } == 0 ;
 490
 491     my (@Bad) ;
 492     my @entered = () ;
 493
 494     # Allow the options to be passed as a hash reference or
 495     # as the complete hash.
 496     if (@_ == 0) {
 497         @entered = () ;
 498     }
 499     elsif (@_ == 1) {
 500         my $href = $_[0] ;
 501         return $self->setError("Expected even number of parameters, got 1")
 502             if ! defined $href or ! ref $href or ref $href ne "HASH" ;
 503
 504         foreach my $key (keys %$href) {
 505             push @entered, $key ;
 506             push @entered, \$href->{$key} ;
 507         }
 508     }
 509     else {
 510         my $count = @_;
 511         return $self->setError("Expected even number of parameters, got $count")
 512             if $count % 2 != 0 ;
 513
 514         for my $i (0.. $count / 2 - 1) {
 515             push @entered, $_[2* $i] ;
 516             push @entered, \$_[2* $i+1] ;
 517         }
 518     }
 519
 520
 521     while (my ($key, $v) = each %$default)
 522     {
 523         croak "need 4 params [@$v]"
 524             if @$v != 4 ;
 525
 526         my ($first_only, $sticky, $type, $value) = @$v ;
 527         my $x ;
 528         $self->_checkType($key, \$value, $type, 0, \$x)
 529             or return undef ;
 530
 531         $key = lc $key;
 532
 533         if ($firstTime || ! $sticky) {
 534             $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
 535         }
 536
 537         $got->{$key}[OFF_PARSED] = 0 ;
 538     }
 539
 540     for my $i (0.. @entered / 2 - 1) {
 541         my $key = $entered[2* $i] ;
 542         my $value = $entered[2* $i+1] ;
 543
 544         #print "Key [$key] Value [$value]" ;
 545         #print defined $$value ? "[$$value]\n" : "[undef]\n";
 546
 547         $key =~ s/^-// ;
 548         my $canonkey = lc $key;
 549
 550         if ($got->{$canonkey} && ($firstTime ||
 551                                   ! $got->{$canonkey}[OFF_FIRST_ONLY]  ))
 552         {
 553             my $type = $got->{$canonkey}[OFF_TYPE] ;
 554             my $s ;
 555             $self->_checkType($key, $value, $type, 1, \$s)
 556                 or return undef ;
 557             #$value = $$value unless $type & Parse_store_ref ;
 558             $value = $$value ;
 559             $got->{$canonkey} = [1, $type, $value, $s] ;
 560         }
 561         else
 562           { push (@Bad, $key) }
 563     }
 564
 565     if (@Bad) {
 566         my ($bad) = join(", ", @Bad) ;
 567         return $self->setError("unknown key value(s) @Bad") ;
 568     }
 569
 570     return 1;
 571 }
 572
 573 sub IO::Compress::Base::Parameters::_checkType
 574 {
 575     my $self = shift ;
 576
 577     my $key   = shift ;
 578     my $value = shift ;
 579     my $type  = shift ;
 580     my $validate  = shift ;
 581     my $output  = shift;
 582
 583     #local $Carp::CarpLevel = $level ;
 584     #print "PARSE $type $key $value $validate $sub\n" ;
 585     if ( $type & Parse_store_ref)
 586     {
 587         #$value = $$value
 588         #    if ref ${ $value } ;
 589
 590         $$output = $value ;
 591         return 1;
 592     }
 593
 594     $value = $$value ;
 595
 596     if ($type & Parse_any)
 597     {
 598         $$output = $value ;
 599         return 1;
 600     }
 601     elsif ($type & Parse_unsigned)
 602     {
 603         return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
 604             if $validate && ! defined $value ;
 605         return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
 606             if $validate && $value !~ /^\d+$/;
 607
 608         $$output = defined $value ? $value : 0 ;
 609         return 1;
 610     }
 611     elsif ($type & Parse_signed)
 612     {
 613         return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
 614             if $validate && ! defined $value ;
 615         return $self->setError("Parameter '$key' must be a signed int, got '$value'")
 616             if $validate && $value !~ /^-?\d+$/;
 617
 618         $$output = defined $value ? $value : 0 ;
 619         return 1 ;
 620     }
 621     elsif ($type & Parse_boolean)
 622     {
 623         return $self->setError("Parameter '$key' must be an int, got '$value'")
 624             if $validate && defined $value && $value !~ /^\d*$/;
 625         $$output =  defined $value ? $value != 0 : 0 ;
 626         return 1;
 627     }
 628     elsif ($type & Parse_string)
 629     {
 630         $$output = defined $value ? $value : "" ;
 631         return 1;
 632     }
 633
 634     $$output = $value ;
 635     return 1;
 636 }
 637
 638
 639
 640 sub IO::Compress::Base::Parameters::parsed
 641 {
 642     my $self = shift ;
 643     my $name = shift ;
 644
 645     return $self->{Got}{lc $name}[OFF_PARSED] ;
 646 }
 647
 648 sub IO::Compress::Base::Parameters::value
 649 {
 650     my $self = shift ;
 651     my $name = shift ;
 652
 653     if (@_)
 654     {
 655         $self->{Got}{lc $name}[OFF_PARSED]  = 1;
 656         $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
 657         $self->{Got}{lc $name}[OFF_FIXED]   = $_[0] ;
 658     }
 659
 660     return $self->{Got}{lc $name}[OFF_FIXED] ;
 661 }
 662
 663 sub IO::Compress::Base::Parameters::valueOrDefault
 664 {
 665     my $self = shift ;
 666     my $name = shift ;
 667     my $default = shift ;
 668
 669     my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
 670
 671     return $value if defined $value ;
 672     return $default ;
 673 }
 674
 675 sub IO::Compress::Base::Parameters::wantValue
 676 {
 677     my $self = shift ;
 678     my $name = shift ;
 679
 680     return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
 681
 682 }
 683
 684 sub IO::Compress::Base::Parameters::clone
 685 {
 686     my $self = shift ;
 687     my $obj = { };
 688     my %got ;
 689
 690     while (my ($k, $v) = each %{ $self->{Got} }) {
 691         $got{$k} = [ @$v ];
 692     }
 693
 694     $obj->{Error} = $self->{Error};
 695     $obj->{Got} = \%got ;
 696
 697     return bless $obj, 'IO::Compress::Base::Parameters' ;
 698 }
 699
 700 package IO::Compress::Base::Common;
 701
 702 1;