ext/Compress/Zlib/lib/IO/Compress/Gzip.pm

   1
   2 package IO::Compress::Gzip ;
   3
   4 require 5.004 ;
   5
   6 use strict ;
   7 use warnings;
   8
   9 # create RFC1952
  10
  11 require Exporter ;
  12
  13 our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError);
  14
  15 $VERSION = '2.000_05';
  16 $GzipError = '' ;
  17
  18 @ISA    = qw(Exporter IO::BaseDeflate);
  19 @EXPORT_OK = qw( $GzipError gzip ) ;
  20 %EXPORT_TAGS = %IO::BaseDeflate::EXPORT_TAGS ;
  21 push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
  22 Exporter::export_ok_tags('all');
  23
  24 sub new
  25 {
  26     my $pkg = shift ;
  27     return IO::BaseDeflate::new($pkg, 'rfc1952', undef, \$GzipError, @_);
  28 }
  29
  30
  31 sub gzip
  32 {
  33     return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1952', \$GzipError, @_);
  34 }
  35
  36 package IO::BaseDeflate;
  37
  38
  39 use Compress::Zlib 2 ;
  40 use Compress::Zlib::Common;
  41 use Compress::Zlib::FileConstants;
  42 use Compress::Zlib::ParseParameters;
  43 use Compress::Gzip::Constants;
  44 use IO::Uncompress::Gunzip;
  45
  46 use IO::File ;
  47 #use File::Glob;
  48 require Exporter ;
  49 use Carp ;
  50 use Symbol;
  51 use bytes;
  52
  53 our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS, $got_encode);
  54 @ISA    = qw(Exporter IO::File);
  55 %EXPORT_TAGS = ( flush     => [qw{
  56                                     Z_NO_FLUSH
  57                                     Z_PARTIAL_FLUSH
  58                                     Z_SYNC_FLUSH
  59                                     Z_FULL_FLUSH
  60                                     Z_FINISH
  61                                     Z_BLOCK
  62                               }],
  63                  level     => [qw{
  64                                     Z_NO_COMPRESSION
  65                                     Z_BEST_SPEED
  66                                     Z_BEST_COMPRESSION
  67                                     Z_DEFAULT_COMPRESSION
  68                               }],
  69                  strategy  => [qw{
  70                                     Z_FILTERED
  71                                     Z_HUFFMAN_ONLY
  72                                     Z_RLE
  73                                     Z_FIXED
  74                                     Z_DEFAULT_STRATEGY
  75                               }],
  76
  77               );
  78
  79 {
  80     my %seen;
  81     foreach (keys %EXPORT_TAGS )
  82     {
  83         push @{$EXPORT_TAGS{constants}},
  84                  grep { !$seen{$_}++ }
  85                  @{ $EXPORT_TAGS{$_} }
  86     }
  87     $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ;
  88 }
  89
  90 Exporter::export_ok_tags('all');
  91
  92
  93 BEGIN
  94 {
  95     if (defined &utf8::downgrade )
  96       { *noUTF8 = \&utf8::downgrade }
  97     else
  98       { *noUTF8 = sub {} }
  99 }
 100
 101
 102 $VERSION = '2.000_03';
 103
 104 #Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16.
 105
 106 #$got_encode = 0;
 107 #eval
 108 #{
 109 #    require Encode;
 110 #    Encode->import('encode', 'find_encoding');
 111 #};
 112 #
 113 #$got_encode = 1 unless $@;
 114
 115 sub saveStatus
 116 {
 117     my $self   = shift ;
 118     ${ *$self->{ErrorNo} } = shift() + 0 ;
 119     ${ *$self->{Error} } = '' ;
 120
 121     return ${ *$self->{ErrorNo} } ;
 122 }
 123
 124
 125 sub saveErrorString
 126 {
 127     my $self   = shift ;
 128     my $retval = shift ;
 129     ${ *$self->{Error} } = shift ;
 130     ${ *$self->{ErrorNo} } = shift() + 0 if @_ ;
 131
 132     return $retval;
 133 }
 134
 135 sub error
 136 {
 137     my $self   = shift ;
 138     return ${ *$self->{Error} } ;
 139 }
 140
 141 sub errorNo
 142 {
 143     my $self   = shift ;
 144     return ${ *$self->{ErrorNo} } ;
 145 }
 146
 147 sub bitmask($$$$)
 148 {
 149     my $into  = shift ;
 150     my $value  = shift ;
 151     my $offset = shift ;
 152     my $mask   = shift ;
 153
 154     return $into | (($value & $mask) << $offset ) ;
 155 }
 156
 157 sub mkDeflateHdr($$$;$)
 158 {
 159     my $method = shift ;
 160     my $cinfo  = shift;
 161     my $level  = shift;
 162     my $fdict_adler = shift  ;
 163
 164     my $cmf = 0;
 165     my $flg = 0;
 166     my $fdict = 0;
 167     $fdict = 1 if defined $fdict_adler;
 168
 169     $cmf = bitmask($cmf, $method, ZLIB_CMF_CM_OFFSET,    ZLIB_CMF_CM_BITS);
 170     $cmf = bitmask($cmf, $cinfo,  ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS);
 171
 172     $flg = bitmask($flg, $fdict,  ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS);
 173     $flg = bitmask($flg, $level,  ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS);
 174
 175     my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ;
 176     $flg = bitmask($flg, $fcheck, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS);
 177
 178     my $hdr =  pack("CC", $cmf, $flg) ;
 179     $hdr .= pack("N", $fdict_adler) if $fdict ;
 180
 181     return $hdr;
 182 }
 183
 184 sub mkDeflateHeader ($)
 185 {
 186     my $param = shift ;
 187
 188     my $level = $param->value('Level');
 189     my $strategy = $param->value('Strategy');
 190
 191     my $lflag ;
 192     $level = 6
 193         if $level == Z_DEFAULT_COMPRESSION ;
 194
 195     if (ZLIB_VERNUM >= 0x1210)
 196     {
 197         if ($strategy >= Z_HUFFMAN_ONLY || $level < 2)
 198          {  $lflag = ZLIB_FLG_LEVEL_FASTEST }
 199         elsif ($level < 6)
 200          {  $lflag = ZLIB_FLG_LEVEL_FAST }
 201         elsif ($level == 6)
 202          {  $lflag = ZLIB_FLG_LEVEL_DEFAULT }
 203         else
 204          {  $lflag = ZLIB_FLG_LEVEL_SLOWEST }
 205     }
 206     else
 207     {
 208         $lflag = ($level - 1) >> 1 ;
 209         $lflag = 3 if $lflag > 3 ;
 210     }
 211
 212      #my $wbits = (MAX_WBITS - 8) << 4 ;
 213     my $wbits = 7;
 214     mkDeflateHdr(ZLIB_CMF_CM_DEFLATED, $wbits, $lflag);
 215 }
 216
 217 sub mkGzipHeader
 218 {
 219     my $param = shift ;
 220
 221     # stort-circuit if a minimal header is requested.
 222     return GZIP_MINIMUM_HEADER if $param->value('Minimal') ;
 223
 224     # METHOD
 225     my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ;
 226
 227     # FLAGS
 228     my $flags       = GZIP_FLG_DEFAULT ;
 229     $flags |= GZIP_FLG_FTEXT    if $param->value('TextFlag') ;
 230     $flags |= GZIP_FLG_FHCRC    if $param->value('HeaderCRC') ;
 231     $flags |= GZIP_FLG_FEXTRA   if $param->wantValue('ExtraField') ;
 232     $flags |= GZIP_FLG_FNAME    if $param->wantValue('Name') ;
 233     $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ;
 234
 235     # MTIME
 236     my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ;
 237
 238     # EXTRA FLAGS
 239     my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT);
 240
 241     # OS CODE
 242     my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ;
 243
 244
 245     my $out = pack("C4 V C C",
 246             GZIP_ID1,   # ID1
 247             GZIP_ID2,   # ID2
 248             $method,    # Compression Method
 249             $flags,     # Flags
 250             $time,      # Modification Time
 251             $extra_flags, # Extra Flags
 252             $os_code,   # Operating System Code
 253             ) ;
 254
 255     # EXTRA
 256     if ($flags & GZIP_FLG_FEXTRA) {
 257         my $extra = $param->value('ExtraField') ;
 258         $out .= pack("v", length $extra) . $extra ;
 259     }
 260
 261     # NAME
 262     if ($flags & GZIP_FLG_FNAME) {
 263         my $name .= $param->value('Name') ;
 264         $name =~ s/\x00.*$//;
 265         $out .= $name ;
 266         # Terminate the filename with NULL unless it already is
 267         $out .= GZIP_NULL_BYTE
 268             if !length $name or
 269                substr($name, 1, -1) ne GZIP_NULL_BYTE ;
 270     }
 271
 272     # COMMENT
 273     if ($flags & GZIP_FLG_FCOMMENT) {
 274         my $comment .= $param->value('Comment') ;
 275         $comment =~ s/\x00.*$//;
 276         $out .= $comment ;
 277         # Terminate the comment with NULL unless it already is
 278         $out .= GZIP_NULL_BYTE
 279             if ! length $comment or
 280                substr($comment, 1, -1) ne GZIP_NULL_BYTE;
 281     }
 282
 283     # HEADER CRC
 284     $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ;
 285
 286     noUTF8($out);
 287
 288     return $out ;
 289 }
 290
 291 sub ExtraFieldError
 292 {
 293     return "Error with ExtraField Parameter: $_[0]" ;
 294 }
 295
 296 sub validateExtraFieldPair
 297 {
 298     my $pair = shift ;
 299     my $lax  = shift ;
 300
 301     return ExtraFieldError("Not an array ref")
 302         unless ref $pair &&  ref $pair eq 'ARRAY';
 303
 304     return ExtraFieldError("SubField must have two parts")
 305         unless @$pair == 2 ;
 306
 307     return ExtraFieldError("SubField ID is a reference")
 308         if ref $pair->[0] ;
 309
 310     return ExtraFieldError("SubField Data is a reference")
 311         if ref $pair->[1] ;
 312
 313     # ID is exactly two chars
 314     return ExtraFieldError("SubField ID not two chars long")
 315         unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ;
 316
 317     # Check that the 2nd byte of the ID isn't 0
 318     return ExtraFieldError("SubField ID 2nd byte is 0x00")
 319         if ! $lax && substr($pair->[0], 1, 1) eq "\x00" ;
 320
 321     return ExtraFieldError("SubField Data too long")
 322         if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ;
 323
 324
 325     return undef ;
 326 }
 327
 328 sub parseExtra
 329 {
 330     my $data = shift ;
 331     my $lax = shift ;
 332
 333     return undef
 334         if $lax ;
 335
 336     my $XLEN = length $data ;
 337
 338     return ExtraFieldError("Too Large")
 339         if $XLEN > GZIP_FEXTRA_MAX_SIZE;
 340
 341     my $offset = 0 ;
 342     while ($offset < $XLEN) {
 343
 344         return ExtraFieldError("FEXTRA Body")
 345             if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE  > $XLEN ;
 346
 347         my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
 348         $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
 349
 350         my $subLen =  unpack("v", substr($data, $offset,
 351                                             GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
 352         $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
 353
 354         return ExtraFieldError("FEXTRA Body")
 355             if $offset + $subLen > $XLEN ;
 356
 357         my $bad = validateExtraFieldPair( [$id,
 358                                             substr($data, $offset, $subLen)], $lax );
 359         return $bad if $bad ;
 360
 361         $offset += $subLen ;
 362     }
 363
 364     return undef ;
 365 }
 366
 367 sub parseExtraField
 368 {
 369     my $self = shift ;
 370     my $got  = shift ;
 371     my $lax  = shift ;
 372
 373     # ExtraField can be any of
 374     #
 375     #    -ExtraField => $data
 376     #    -ExtraField => [$id1, $data1,
 377     #                    $id2, $data2]
 378     #                     ...
 379     #                   ]
 380     #    -ExtraField => [ [$id1 => $data1],
 381     #                     [$id2 => $data2],
 382     #                     ...
 383     #                   ]
 384     #    -ExtraField => { $id1 => $data1,
 385     #                     $id2 => $data2,
 386     #                     ...
 387     #                   }
 388
 389
 390     return undef
 391         unless $got->parsed('ExtraField') ;
 392
 393     return parseExtra($got->value('ExtraField'), $lax)
 394         unless ref $got->value('ExtraField') ;
 395
 396     my $data = $got->value('ExtraField');
 397     my $out = '' ;
 398
 399     if (ref $data eq 'ARRAY') {
 400         if (ref $data->[0]) {
 401
 402             foreach my $pair (@$data) {
 403                 return ExtraFieldError("Not list of lists")
 404                     unless ref $pair eq 'ARRAY' ;
 405
 406                 my $bad = validateExtraFieldPair($pair, $lax) ;
 407                 return $bad if $bad ;
 408
 409                 $out .= $pair->[0] . pack("v", length $pair->[1]) .
 410                         $pair->[1] ;
 411             }
 412         }
 413         else {
 414             return ExtraFieldError("Not even number of elements")
 415                 unless @$data % 2  == 0;
 416
 417             for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) {
 418                 my $bad = validateExtraFieldPair([$data->[$ix], $data->[$ix+1]], $lax) ;
 419                 return $bad if $bad ;
 420
 421                 $out .= $data->[$ix] . pack("v", length $data->[$ix+1]) .
 422                         $data->[$ix+1] ;
 423             }
 424         }
 425     }
 426     elsif (ref $data eq 'HASH') {
 427         while (my ($id, $info) = each %$data) {
 428             my $bad = validateExtraFieldPair([$id, $info], $lax);
 429             return $bad if $bad ;
 430
 431             $out .= $id .  pack("v", length $info) . $info ;
 432         }
 433     }
 434     else {
 435         return ExtraFieldError("Not a scalar, array ref or hash ref") ;
 436     }
 437
 438     $got->value('ExtraField' => $out);
 439
 440     return undef;
 441 }
 442
 443 sub checkParams
 444 {
 445     my $class = shift ;
 446     my $type = shift ;
 447
 448     my $rfc1952 = ($type eq 'rfc1952');
 449     my $rfc1950 = ($type eq 'rfc1950');
 450
 451     my $got = Compress::Zlib::ParseParameters::new();
 452
 453     $got->parse(
 454         $rfc1952 ?
 455         {
 456             'AutoClose'=> [Parse_boolean,   0],
 457             #'Encoding'=> [Parse_any,       undef],
 458             'Strict'   => [Parse_boolean,   1],
 459             'Append'   => [Parse_boolean,   0],
 460             'Merge'    => [Parse_boolean,   0],
 461
 462             # zlib behaviour
 463             #'Method'   => [Parse_unsigned,  Z_DEFLATED],
 464             'Level'     => [Parse_signed,    Z_DEFAULT_COMPRESSION],
 465             'Strategy'  => [Parse_signed,    Z_DEFAULT_STRATEGY],
 466
 467             # Gzip header fields
 468             'Minimal'   => [Parse_boolean,   0],
 469             'Comment'   => [Parse_any,       undef],
 470             'Name'      => [Parse_any,       undef],
 471             'Time'      => [Parse_any,       undef],
 472             'TextFlag'  => [Parse_boolean,   0],
 473             'HeaderCRC' => [Parse_boolean,   0],
 474             'OS_Code'   => [Parse_unsigned,  $Compress::Zlib::gzip_os_code],
 475             'ExtraField'=> [Parse_string,    undef],
 476             'ExtraFlags'=> [Parse_any,       undef],
 477         }
 478         :
 479         {
 480             'AutoClose' => [Parse_boolean,   0],
 481             #'Encoding' => [Parse_any,       undef],
 482             'CRC32'     => [Parse_boolean,   0],
 483             'ADLER32'   => [Parse_boolean,   0],
 484             'Strict'    => [Parse_boolean,   1],
 485             'Append'    => [Parse_boolean,   0],
 486             'Merge'     => [Parse_boolean,   0],
 487
 488             # zlib behaviour
 489             #'Method'   => [Parse_unsigned,  Z_DEFLATED],
 490             'Level'     => [Parse_signed,    Z_DEFAULT_COMPRESSION],
 491             'Strategy'  => [Parse_signed,    Z_DEFAULT_STRATEGY],
 492         },
 493         @_) or croak "${class}: $got->{Error}"  ;
 494
 495     return $got ;
 496 }
 497
 498 sub new
 499 {
 500     my $class = shift ;
 501     my $type = shift ;
 502     my $got = shift;
 503     my $error_ref = shift ;
 504
 505     croak("$class: Missing Output parameter")
 506         if ! @_ && ! $got ;
 507
 508     my $outValue = shift ;
 509     my $oneShot = 1 ;
 510
 511     if (! $got)
 512     {
 513         $oneShot = 0 ;
 514         $got = checkParams($class, $type, @_)
 515             or return undef ;
 516     }
 517
 518     my $rfc1952 = ($type eq 'rfc1952');
 519     my $rfc1950 = ($type eq 'rfc1950');
 520     my $rfc1951 = ($type eq 'rfc1951');
 521
 522     my $obj = bless Symbol::gensym(), ref($class) || $class;
 523     tie *$obj, $obj if $] >= 5.005;
 524
 525     *$obj->{Closed} = 1 ;
 526     $$error_ref = '' ;
 527     *$obj->{Error} = $error_ref ;
 528
 529     my $lax = ! $got->value('Strict') ;
 530
 531     my $outType = whatIsOutput($outValue);
 532
 533     ckOutputParam($class, $outValue, $error_ref)
 534         or return undef ;
 535
 536     if ($outType eq 'buffer') {
 537         *$obj->{Buffer} = $outValue;
 538     }
 539     else {
 540         my $buff = "" ;
 541         *$obj->{Buffer} = \$buff ;
 542     }
 543
 544     # Merge implies Append
 545     my $merge = $got->value('Merge') ;
 546     my $appendOutput = $got->value('Append') || $merge ;
 547
 548     if ($merge)
 549     {
 550         # Switch off Merge mode if output file/buffer is empty/doesn't exist
 551         if (($outType eq 'buffer' && length $$outValue == 0 ) ||
 552             ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) )
 553           { $merge = 0 }
 554     }
 555
 556     # If output is a file, check that it is writable
 557     if ($outType eq 'filename' && -e $outValue && ! -w _)
 558       { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) }
 559
 560     elsif ($outType eq 'handle'  && ! -w $outValue)
 561       { return $obj->saveErrorString(undef, "Output filehandle is not writable" ) }
 562
 563
 564 #    TODO - encoding
 565 #    if ($got->parsed('Encoding')) {
 566 #        croak("$class: Encode module needed to use -Encoding")
 567 #            if ! $got_encode;
 568 #
 569 #        my $want_encoding = $got->value('Encoding');
 570 #        my $encoding = find_encoding($want_encoding);
 571 #
 572 #        croak("$class: Encoding '$want_encoding' is not available")
 573 #           if ! $encoding;
 574 #
 575 #        *$obj->{Encoding} = $encoding;
 576 #    }
 577
 578     if ($rfc1952 && ! $merge) {
 579
 580         if (! $got->parsed('Time') ) {
 581             # Modification time defaults to now.
 582             $got->value('Time' => time) ;
 583         }
 584
 585         # Check that the Name & Comment don't have embedded NULLs
 586         # Also check that they only contain ISO 8859-1 chars.
 587         if ($got->parsed('Name') && defined $got->value('Name')) {
 588             my $name = $got->value('Name');
 589
 590             return $obj->saveErrorString(undef, "Null Character found in Name",
 591                                                 Z_DATA_ERROR)
 592                 if ! $lax && $name =~ /\x00/ ;
 593
 594             return $obj->saveErrorString(undef, "Non ISO 8859-1 Character found in Name",
 595                                                 Z_DATA_ERROR)
 596                 if ! $lax && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ;
 597         }
 598
 599         if ($got->parsed('Comment') && defined $got->value('Comment')) {
 600             my $comment = $got->value('Comment');
 601
 602             return $obj->saveErrorString(undef, "Null Character found in Comment",
 603                                                 Z_DATA_ERROR)
 604                 if ! $lax && $comment =~ /\x00/ ;
 605
 606             return $obj->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment",
 607                                                 Z_DATA_ERROR)
 608                 if ! $lax && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o;
 609         }
 610
 611         if ($got->parsed('OS_Code') ) {
 612             my $value = $got->value('OS_Code');
 613
 614             return $obj->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'")
 615                 if $value < 0 || $value > 255 ;
 616
 617         }
 618
 619         # gzip only supports Deflate at present
 620         $got->value('Method' => Z_DEFLATED) ;
 621
 622         if ( ! $got->parsed('ExtraFlags')) {
 623             $got->value('ExtraFlags' => 2)
 624                 if $got->value('Level') == Z_BEST_SPEED ;
 625             $got->value('ExtraFlags' => 4)
 626                 if $got->value('Level') == Z_BEST_COMPRESSION ;
 627         }
 628
 629         if ($got->parsed('ExtraField')) {
 630
 631             my $bad = $obj->parseExtraField($got, $lax) ;
 632             return $obj->saveErrorString(undef, $bad, Z_DATA_ERROR)
 633                 if $bad ;
 634
 635             my $len = length $got->value('ExtraField') ;
 636             return $obj->saveErrorString(undef, ExtraFieldError("Too Large"),
 637                                                         Z_DATA_ERROR)
 638                 if $len > GZIP_FEXTRA_MAX_SIZE;
 639         }
 640     }
 641
 642     $obj->saveStatus(Z_OK) ;
 643
 644     my $end_offset = 0;
 645     my $status ;
 646     if (! $merge)
 647     {
 648         (*$obj->{Deflate}, $status) = new Compress::Zlib::Deflate
 649                         -AppendOutput   => 1,
 650                         -CRC32          => $rfc1952 || $got->value('CRC32'),
 651                         -ADLER32        => $rfc1950 || $got->value('ADLER32'),
 652                         -Level          => $got->value('Level'),
 653                         -Strategy       => $got->value('Strategy'),
 654                         -WindowBits     => - MAX_WBITS;
 655         return $obj->saveErrorString(undef, "Cannot create Deflate object: $status" )
 656             if $obj->saveStatus($status) != Z_OK ;
 657
 658         *$obj->{BytesWritten} = 0 ;
 659         *$obj->{ISize} = 0 ;
 660
 661         *$obj->{Header} = mkDeflateHeader($got)
 662             if $rfc1950 ;
 663         *$obj->{Header} = ''
 664             if $rfc1951 ;
 665         *$obj->{Header} = mkGzipHeader($got)
 666             if $rfc1952 ;
 667
 668         if ( $outType eq 'buffer') {
 669             ${ *$obj->{Buffer} }  = ''
 670                 unless $appendOutput ;
 671             ${ *$obj->{Buffer} } .= *$obj->{Header};
 672         }
 673         else {
 674             if ($outType eq 'handle') {
 675                 $outValue->flush() ;
 676                 *$obj->{FH} = $outValue ;
 677                 *$obj->{Handle} = 1 ;
 678                 if ($appendOutput)
 679                 {
 680                     seek(*$obj->{FH}, 0, SEEK_END)
 681                         or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
 682
 683                 }
 684             }
 685             elsif ($outType eq 'filename') {
 686                 my $mode = '>' ;
 687                 $mode = '>>'
 688                     if $appendOutput;
 689                 *$obj->{FH} = new IO::File "$mode $outValue"
 690                     or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ;
 691                 *$obj->{StdIO} = ($outValue eq '-');
 692             }
 693
 694             setBinModeOutput(*$obj->{FH}) ;
 695
 696             if (!$rfc1951) {
 697                 defined *$obj->{FH}->write(*$obj->{Header}, length(*$obj->{Header}))
 698                     or return $obj->saveErrorString(undef, $!, $!) ;
 699             }
 700         }
 701     }
 702     else
 703     {
 704         my %mapping = ( 'rfc1952'  => ['IO::Uncompress::Gunzip',     \$IO::Uncompress::Gunzip::GunzipError],
 705                         'rfc1950'  => ['IO::Uncompress::Inflate',    \$IO::Uncompress::Inflate::InflateError],
 706                         'rfc1951'  => ['IO::Uncompress::RawInflate', \$IO::Uncompress::RawInflate::RawInflateError],
 707                       );
 708
 709         my $inf = IO::BaseInflate::new($mapping{$type}[0],
 710                                    $type, undef,
 711                                    $error_ref, 0, $outValue,
 712                                    Transparent => 0,
 713                                    #Strict      => 1,
 714                                    AutoClose   => 0,
 715                                    Scan        => 1);
 716
 717         return $obj->saveErrorString(undef, "Cannot create InflateScan object: $$error_ref" )
 718             if ! defined $inf ;
 719
 720         $inf->scan()
 721             or return $obj->saveErrorString(undef, "Error Scanning: $$error_ref", $inf->errorNo) ;
 722         $inf->zap($end_offset)
 723             or return $obj->saveErrorString(undef, "Error Zapping: $$error_ref", $inf->errorNo) ;
 724
 725         (*$obj->{Deflate}, $status) = $inf->createDeflate();
 726
 727         *$obj->{Header} = *$inf->{Info}{Header};
 728         *$obj->{ISize} =
 729         *$obj->{ISize} = *$obj->{BytesWritten} = *$inf->{ISize} ;
 730
 731         if ( $outType eq 'buffer')
 732           { substr( ${ *$obj->{Buffer} }, $end_offset) = '' }
 733         elsif ($outType eq 'handle' || $outType eq 'filename') {
 734             *$obj->{FH} = *$inf->{FH} ;
 735             delete *$inf->{FH};
 736             *$obj->{FH}->flush() ;
 737             *$obj->{Handle} = 1 if $outType eq 'handle';
 738
 739             #seek(*$obj->{FH}, $end_offset, SEEK_SET)
 740             *$obj->{FH}->seek($end_offset, SEEK_SET)
 741                 or return $obj->saveErrorString(undef, $!, $!) ;
 742         }
 743     }
 744
 745     *$obj->{Closed} = 0 ;
 746     *$obj->{AutoClose} = $got->value('AutoClose') ;
 747     *$obj->{OutputGzip} = $rfc1952;
 748     *$obj->{OutputDeflate} = $rfc1950;
 749     *$obj->{OutputRawDeflate} = $rfc1951;
 750     *$obj->{Output} = $outValue;
 751     *$obj->{ClassName} = $class;
 752
 753     return $obj ;
 754 }
 755
 756 sub _def
 757 {
 758     my $class     = shift ;
 759     my $type      = shift ;
 760     my $error_ref = shift ;
 761
 762     my $name = (caller(1))[3] ;
 763
 764     croak "$name: expected at least 1 parameters\n"
 765         unless @_ >= 1 ;
 766
 767     my $input = shift ;
 768     my $haveOut = @_ ;
 769     my $output = shift ;
 770
 771     my $x = new Validator($class, $type, $error_ref, $name, $input, $output)
 772         or return undef ;
 773
 774     push @_, $output if $haveOut && $x->{Hash};
 775
 776     my $got = checkParams($name, $type, @_)
 777         or return undef ;
 778
 779     $x->{Got} = $got ;
 780     $x->{ParsedTime} = $got->parsed('Time') ;
 781     $x->{ParsedName} = $got->parsed('Name') ;
 782
 783     if ($x->{Hash})
 784     {
 785         while (my($k, $v) = each %$input)
 786         {
 787             $v = \$input->{$k}
 788                 unless defined $v ;
 789
 790             _singleTarget($x, 1, $k, $v, @_)
 791                 or return undef ;
 792         }
 793
 794         return keys %$input ;
 795     }
 796
 797     if ($x->{GlobMap})
 798     {
 799         $x->{oneInput} = 1 ;
 800         foreach my $pair (@{ $x->{Pairs} })
 801         {
 802             my ($from, $to) = @$pair ;
 803             _singleTarget($x, 1, $from, $to, @_)
 804                 or return undef ;
 805         }
 806
 807         return scalar @{ $x->{Pairs} } ;
 808     }
 809
 810     if (! $x->{oneOutput} )
 811     {
 812         my $inFile = ($x->{inType} eq 'filenames'
 813                         || $x->{inType} eq 'filename');
 814
 815         $x->{inType} = $inFile ? 'filename' : 'buffer';
 816
 817         foreach my $in ($x->{oneInput} ? $input : @$input)
 818         {
 819             my $out ;
 820             $x->{oneInput} = 1 ;
 821
 822             _singleTarget($x, $inFile, $in, \$out, @_)
 823                 or return undef ;
 824
 825             if ($x->{outType} eq 'array')
 826               { push @$output, \$out }
 827             else
 828               { $output->{$in} = \$out }
 829         }
 830
 831         return 1 ;
 832     }
 833
 834     # finally the 1 to 1 and n to 1
 835     return _singleTarget($x, 1, $input, $output, @_);
 836
 837     croak "should not be here" ;
 838 }
 839
 840 sub _singleTarget
 841 {
 842     my $x               = shift ;
 843     my $inputIsFilename = shift;
 844     my $input           = shift;
 845
 846
 847     # For gzip, if input is simple filename, populate Name & Time in
 848     # gzip header from filename by default.
 849     if ($x->{Type} eq 'rfc1952' and isaFilename($input) and $inputIsFilename)
 850     {
 851         my $defaultTime = (stat($input))[8] ;
 852
 853         $x->{Got}->value('Name' => $input)
 854             if ! $x->{ParsedName};
 855
 856         $x->{Got}->value('Time' => $defaultTime)
 857             if ! $x->{ParsedTime};
 858     }
 859
 860     my $gzip = new($x->{Class}, $x->{Type}, $x->{Got}, $x->{Error}, @_)
 861         or return undef ;
 862
 863
 864     if ($x->{oneInput})
 865     {
 866         defined $gzip->_wr2($input, $inputIsFilename)
 867             or return undef ;
 868     }
 869     else
 870     {
 871         my $afterFirst = 0 ;
 872         my $inputIsFilename = ($x->{inType} ne 'array');
 873
 874         for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
 875         {
 876             if ( $afterFirst ++ )
 877             {
 878                 defined addInterStream($gzip, $x, $element, $inputIsFilename)
 879                     or return undef ;
 880             }
 881
 882             defined $gzip->_wr2($element, $inputIsFilename)
 883                 or return undef ;
 884         }
 885     }
 886
 887     return $gzip->close() ;
 888 }
 889
 890 sub _wr2
 891 {
 892     my $self = shift ;
 893
 894     my $source = shift ;
 895     my $inputIsFilename = shift;
 896
 897     my $input = $source ;
 898     if (! $inputIsFilename)
 899     {
 900         $input = \$source
 901             if ! ref $source;
 902     }
 903
 904     if ( ref $input && ref $input eq 'SCALAR' )
 905     {
 906         return $self->syswrite($input, @_) ;
 907     }
 908
 909     if ( ! ref $input  || isaFilehandle($input))
 910     {
 911         my $isFilehandle = isaFilehandle($input) ;
 912
 913         my $fh = $input ;
 914
 915         if ( ! $isFilehandle )
 916         {
 917             $fh = new IO::File "<$input"
 918                 or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ;
 919         }
 920         setBinModeInput($fh) ;
 921
 922         my $status ;
 923         my $buff ;
 924         my $count = 0 ;
 925         while (($status = read($fh, $buff, 4096)) > 0) {
 926             $count += length $buff;
 927             defined $self->syswrite($buff, @_)
 928                 or return undef ;
 929         }
 930
 931         return $self->saveErrorString(undef, $!, $!)
 932             if $status < 0 ;
 933
 934         if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-')
 935         {
 936             $fh->close()
 937                 or return undef ;
 938         }
 939
 940         return $count ;
 941     }
 942
 943     croak "Should no be here";
 944     return undef;
 945 }
 946
 947 sub addInterStream
 948 {
 949     my $gzip = shift ;
 950     my $x = shift ;
 951     my $input = shift ;
 952     my $inputIsFilename = shift ;
 953
 954     if ($x->{Got}->value('MultiStream'))
 955     {
 956         # For gzip, if input is simple filename, populate Name & Time in
 957         # gzip header from filename by default.
 958         if ($x->{Type} eq 'rfc1952' and isaFilename($input) and $inputIsFilename)
 959         {
 960             my $defaultTime = (stat($input))[8] ;
 961
 962             $x->{Got}->value('Name' => $input)
 963                 if ! $x->{ParsedName};
 964
 965             $x->{Got}->value('Time' => $defaultTime)
 966                 if ! $x->{ParsedTime};
 967         }
 968
 969         # TODO -- newStream needs to allow gzip header to be modified
 970         return $gzip->newStream();
 971     }
 972     elsif ($x->{Got}->value('AutoFlush'))
 973     {
 974         return $gzip->flush(Z_FULL_FLUSH);
 975     }
 976
 977     return 1 ;
 978 }
 979
 980 sub TIEHANDLE
 981 {
 982     return $_[0] if ref($_[0]);
 983     die "OOPS\n" ;
 984 }
 985
 986 sub UNTIE
 987 {
 988     my $self = shift ;
 989 }
 990
 991 sub DESTROY
 992 {
 993     my $self = shift ;
 994     $self->close() ;
 995
 996     # TODO - memory leak with 5.8.0 - this isn't called until
 997     #        global destruction
 998     #
 999     %{ *$self } = () ;
1000     undef $self ;
1001 }
1002
1003
1004 #sub validateInput
1005 #{
1006 #    my $class = shift ;
1007 #
1008 #    #local $Carp::CarpLevel = 1;
1009 #
1010 #    if ( ! ref $_[0]             ||
1011 #           ref $_[0] eq 'SCALAR' ||
1012 #          #ref $_[0] eq 'CODE'   ||
1013 #           isaFilehandle($_[0]) )
1014 #    {
1015 #        my $inType  = whatIs($_[0]);
1016 #        my $outType = whatIs($_[1]);
1017 #
1018 #        if ($inType eq 'filename' )
1019 #        {
1020 #            croak "$class: input filename is undef or null string"
1021 #                if ! defined $_[0] || $_[0] eq ''  ;
1022 #
1023 #            if ($_[0] ne '-' && ! -e $_[0] )
1024 #            {
1025 #                ${$_[2]} = "input file '$_[0]' does not exist";
1026 #                $_[3] = $!;
1027 #                return undef;
1028 #            }
1029 #
1030 #            if (! -r $_[0] )
1031 #            {
1032 #                ${$_[2]} = "cannot open file '$_[0]': $!";
1033 #                $_[3] = $!;
1034 #                return undef;
1035 #            }
1036 #        }
1037 #        elsif ($inType eq 'fileglob' )
1038 #        {
1039 #            # whatever...
1040 #        }
1041 #
1042 #        croak("$class: input and output $inType are identical")
1043 #            if defined $outType && $inType eq $outType && $_[0] eq $_[1] ;
1044 #
1045 #        return 1 ;
1046 #    }
1047 #
1048 #    croak "$class: input parameter not a filename, filehandle, array ref or scalar ref"
1049 #        unless ref $_[0] eq 'ARRAY' ;
1050 #
1051 #    my $array = shift @_ ;
1052 #    foreach my $element ( @{ $array } )
1053 #    {
1054 #        return undef
1055 #            unless validateInput($class, $element, @_);
1056 #    }
1057 #
1058 #    return 1 ;
1059 #}
1060
1061
1062 #sub write
1063 #{
1064 #    my $self = shift ;
1065 #
1066 #    if ( isaFilehandle $_[0] )
1067 #    {
1068 #        return $self->_wr(@_);
1069 #    }
1070 #
1071 #    if ( ref $_[0])
1072 #    {
1073 #        if ( ref $_[0] eq 'SCALAR' )
1074 #          { return $self->syswrite(@_) }
1075 #
1076 #        if ( ref $_[0] eq 'ARRAY' )
1077 #        {
1078 #            my ($str, $num);
1079 #            validateInput(*$self->{ClassName} . "::write", $_[0], *$self->{Output}, \$str, $num)
1080 #                or return $self->saveErrorString(undef, $str, $num);
1081 #
1082 #            return $self->_wr(@_);
1083 #        }
1084 #
1085 #        croak *$self->{ClassName} . "::write: input parameter not a filename, filehandle, array ref or scalar ref";
1086 #    }
1087 #
1088 #    # Not a reference or a filehandle
1089 #    return $self->syswrite(@_) ;
1090 #}
1091 #
1092 #sub _wr
1093 #{
1094 #    my $self = shift ;
1095 #
1096 #    if ( ref $_[0] && ref $_[0] eq 'SCALAR' )
1097 #    {
1098 #        return $self->syswrite(@_) ;
1099 #    }
1100 #
1101 #    if ( ! ref $_[0]  || isaFilehandle($_[0]))
1102 #    {
1103 #        my $item = shift @_ ;
1104 #        my $isFilehandle = isaFilehandle($item) ;
1105 #
1106 #        my $fh = $item ;
1107 #
1108 #        if ( ! $isFilehandle )
1109 #        {
1110 #            $fh = new IO::File "<$item"
1111 #                or return $self->saveErrorString(undef, "cannot open file '$item': $!", $!) ;
1112 #        }
1113 #
1114 #        my $status ;
1115 #        my $buff ;
1116 #        my $count = 0 ;
1117 #        while (($status = read($fh, $buff, 4096)) > 0) {
1118 #            $count += length $buff;
1119 #            defined $self->syswrite($buff, @_)
1120 #                or return undef ;
1121 #        }
1122 #
1123 #        return $self->saveErrorString(undef, $!, $!)
1124 #            if $status < 0 ;
1125 #
1126 #
1127 #        if ( !$isFilehandle || *$self->{AutoClose} )
1128 #        {
1129 #            $fh->close()
1130 #                or return undef ;
1131 #        }
1132 #
1133 #        return $count ;
1134 #    }
1135 #
1136 #    #if ref $_[0] eq 'CODE' ;
1137 #
1138 #    # then must be ARRAY ref
1139 #    my $count = 0 ;
1140 #    my $array = shift @_ ;
1141 #    foreach my $element ( @{ $array } )
1142 #    {
1143 #        my $got = $self->_wr($element, @_) ;
1144 #
1145 #        return undef
1146 #            unless defined $got ;
1147 #
1148 #        $count += $got ;
1149 #    }
1150 #
1151 #    return $count ;
1152 #}
1153
1154
1155 sub syswrite
1156 {
1157     my $self = shift ;
1158
1159     my $buffer ;
1160     if (ref $_[0] ) {
1161         croak *$self->{ClassName} . "::write: not a scalar reference"
1162             unless ref $_[0] eq 'SCALAR' ;
1163         $buffer = $_[0] ;
1164     }
1165     else {
1166         $buffer = \$_[0] ;
1167     }
1168
1169     if (@_ > 1) {
1170         my $slen = defined $$buffer ? length($$buffer) : 0;
1171         my $len = $slen;
1172         my $offset = 0;
1173         $len = $_[1] if $_[1] < $len;
1174
1175         if (@_ > 2) {
1176             $offset = $_[2] || 0;
1177             croak *$self->{ClassName} . "::write: offset outside string" if $offset > $slen;
1178             if ($offset < 0) {
1179                 $offset += $slen;
1180                 croak *$self->{ClassName} . "::write: offset outside string" if $offset < 0;
1181             }
1182             my $rem = $slen - $offset;
1183             $len = $rem if $rem < $len;
1184         }
1185
1186         $buffer = \substr($$buffer, $offset, $len) ;
1187     }
1188
1189     my $buffer_length = defined $$buffer ? length($$buffer) : 0 ;
1190     *$self->{BytesWritten} += $buffer_length ;
1191     my $rest = GZIP_ISIZE_MAX - *$self->{ISize} ;
1192     if ($buffer_length > $rest) {
1193         *$self->{ISize} = $buffer_length - $rest - 1;
1194     }
1195     else {
1196         *$self->{ISize} += $buffer_length ;
1197     }
1198
1199 #    if (*$self->{Encoding}) {
1200 #        $$buffer = *$self->{Encoding}->encode($$buffer);
1201 #    }
1202
1203     #my $length = length $$buffer;
1204     my $status = *$self->{Deflate}->deflate($buffer, *$self->{Buffer}) ;
1205
1206     return $self->saveErrorString(undef,"Deflate Error: $status")
1207         if $self->saveStatus($status) != Z_OK ;
1208
1209     if ( defined *$self->{FH} and length ${ *$self->{Buffer} }) {
1210         defined *$self->{FH}->write( ${ *$self->{Buffer} }, length ${ *$self->{Buffer} } )
1211           or return $self->saveErrorString(undef, $!, $!);
1212         ${ *$self->{Buffer} } = '' ;
1213     }
1214
1215     return $buffer_length;
1216 }
1217
1218 sub print
1219 {
1220     my $self = shift;
1221
1222     #if (ref $self) {
1223     #    $self = *$self{GLOB} ;
1224     #}
1225
1226     if (defined $\) {
1227         if (defined $,) {
1228             defined $self->syswrite(join($,, @_) . $\);
1229         } else {
1230             defined $self->syswrite(join("", @_) . $\);
1231         }
1232     } else {
1233         if (defined $,) {
1234             defined $self->syswrite(join($,, @_));
1235         } else {
1236             defined $self->syswrite(join("", @_));
1237         }
1238     }
1239 }
1240
1241 sub printf
1242 {
1243     my $self = shift;
1244     my $fmt = shift;
1245     defined $self->syswrite(sprintf($fmt, @_));
1246 }
1247
1248
1249
1250 sub flush
1251 {
1252     my $self = shift ;
1253     my $opt = shift || Z_FINISH ;
1254     my $status = *$self->{Deflate}->flush(*$self->{Buffer}, $opt) ;
1255     return $self->saveErrorString(0,"Deflate Error: $status")
1256         if $self->saveStatus($status) != Z_OK ;
1257
1258     if ( defined *$self->{FH} ) {
1259         *$self->{FH}->clearerr();
1260         defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} })
1261             or return $self->saveErrorString(0, $!, $!);
1262         ${ *$self->{Buffer} } = '' ;
1263     }
1264
1265     return 1;
1266 }
1267
1268 sub newStream
1269 {
1270     my $self = shift ;
1271
1272     $self->_writeTrailer(GZIP_MINIMUM_HEADER)
1273         or return 0 ;
1274
1275     my $status = *$self->{Deflate}->deflateReset() ;
1276     return $self->saveErrorString(0,"Deflate Error: $status")
1277         if $self->saveStatus($status) != Z_OK ;
1278
1279     *$self->{BytesWritten} = 0 ;
1280     *$self->{ISize} = 0 ;
1281
1282     return 1 ;
1283 }
1284
1285 sub _writeTrailer
1286 {
1287     my $self = shift ;
1288     my $nextHeader = shift || '' ;
1289
1290     my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ;
1291     return $self->saveErrorString(0,"Deflate Error: $status")
1292         if $self->saveStatus($status) != Z_OK ;
1293
1294     if (*$self->{OutputGzip}) {
1295         ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(),
1296                                              *$self->{ISize} );
1297         ${ *$self->{Buffer} } .= $nextHeader ;
1298     }
1299
1300     if (*$self->{OutputDeflate}) {
1301         ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() );
1302         ${ *$self->{Buffer} } .= *$self->{Header} ;
1303     }
1304
1305     return 1 if ! defined *$self->{FH} ;
1306
1307     defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} })
1308       or return $self->saveErrorString(0, $!, $!);
1309
1310     ${ *$self->{Buffer} } = '' ;
1311
1312     return 1;
1313 }
1314
1315 sub close
1316 {
1317     my $self = shift ;
1318
1319     return 1 if *$self->{Closed} || ! *$self->{Deflate} ;
1320     *$self->{Closed} = 1 ;
1321
1322     untie *$self
1323         if $] >= 5.008 ;
1324
1325     if (0) {
1326         $self->_writeTrailer()
1327             or return 0 ;
1328     }
1329     else {
1330
1331
1332     my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ;
1333     return $self->saveErrorString(0,"Deflate Error: $status")
1334         if $self->saveStatus($status) != Z_OK ;
1335
1336     if (*$self->{OutputGzip}) {
1337         ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(),
1338                                              *$self->{ISize} );
1339     }
1340
1341     if (*$self->{OutputDeflate}) {
1342         ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() );
1343     }
1344
1345
1346     return 1 if ! defined *$self->{FH} ;
1347
1348     defined *$self->{FH}->write(${ *$self->{Buffer} }, length( ${ *$self->{Buffer} } ))
1349       or return $self->saveErrorString(0, $!, $!);
1350
1351     ${ *$self->{Buffer} } = '' ;
1352   }
1353
1354     if (defined *$self->{FH}) {
1355         #if (! *$self->{Handle} || *$self->{AutoClose}) {
1356         if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
1357             $! = 0 ;
1358             *$self->{FH}->close()
1359                 or return $self->saveErrorString(0, $!, $!);
1360         }
1361         delete *$self->{FH} ;
1362         # This delete can set $! in older Perls, so reset the errno
1363         $! = 0 ;
1364     }
1365
1366     return 1;
1367 }
1368
1369 sub deflateParams
1370 {
1371     my $self = shift ;
1372     my $level = shift ;
1373     my $strategy = shift ;
1374
1375     my $status = *$self->{Deflate}->deflateParams(-Level => $level,
1376                                                   -Strategy => $strategy) ;
1377     return $self->saveErrorString(0,"deflateParams Error: $status")
1378         if $self->saveStatus($status) != Z_OK ;
1379
1380     return 1;
1381 }
1382
1383
1384 #sub total_in
1385 #sub total_out
1386 #sub msg
1387 #
1388 #sub crc
1389 #{
1390 #    my $self = shift ;
1391 #    return *$self->{Deflate}->crc32() ;
1392 #}
1393 #
1394 #sub msg
1395 #{
1396 #    my $self = shift ;
1397 #    return *$self->{Deflate}->msg() ;
1398 #}
1399 #
1400 #sub dict_adler
1401 #{
1402 #    my $self = shift ;
1403 #    return *$self->{Deflate}->dict_adler() ;
1404 #}
1405 #
1406 #sub get_Level
1407 #{
1408 #    my $self = shift ;
1409 #    return *$self->{Deflate}->get_Level() ;
1410 #}
1411 #
1412 #sub get_Strategy
1413 #{
1414 #    my $self = shift ;
1415 #    return *$self->{Deflate}->get_Strategy() ;
1416 #}
1417
1418
1419 sub tell
1420 {
1421     my $self = shift ;
1422
1423     #return *$self->{Deflate}->total_in();
1424     return *$self->{BytesWritten} ;
1425 }
1426
1427 sub eof
1428 {
1429     my $self = shift ;
1430
1431     return *$self->{Closed} ;
1432 }
1433
1434
1435 sub seek
1436 {
1437     my $self     = shift ;
1438     my $position = shift;
1439     my $whence   = shift ;
1440
1441     my $here = $self->tell() ;
1442     my $target = 0 ;
1443
1444     #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
1445     use IO::Handle ;
1446
1447     if ($whence == IO::Handle::SEEK_SET) {
1448         $target = $position ;
1449     }
1450     elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) {
1451         $target = $here + $position ;
1452     }
1453     else {
1454         croak *$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter";
1455     }
1456
1457     # short circuit if seeking to current offset
1458     return 1 if $target == $here ;
1459
1460     # Outlaw any attempt to seek backwards
1461     croak *$self->{ClassName} . "::seek: cannot seek backwards"
1462         if $target < $here ;
1463
1464     # Walk the file to the new offset
1465     my $offset = $target - $here ;
1466
1467     my $buffer ;
1468     defined $self->syswrite("\x00" x $offset)
1469         or return 0;
1470
1471     return 1 ;
1472 }
1473
1474 sub binmode
1475 {
1476     1;
1477 #    my $self     = shift ;
1478 #    return defined *$self->{FH}
1479 #            ? binmode *$self->{FH}
1480 #            : 1 ;
1481 }
1482
1483 sub fileno
1484 {
1485     my $self     = shift ;
1486     return defined *$self->{FH}
1487             ? *$self->{FH}->fileno()
1488             : undef ;
1489 }
1490
1491 sub _notAvailable
1492 {
1493     my $name = shift ;
1494     return sub { croak "$name Not Available: File opened only for output" ; } ;
1495 }
1496
1497 *read     = _notAvailable('read');
1498 *READ     = _notAvailable('read');
1499 *readline = _notAvailable('readline');
1500 *READLINE = _notAvailable('readline');
1501 *getc     = _notAvailable('getc');
1502 *GETC     = _notAvailable('getc');
1503
1504 *FILENO   = \&fileno;
1505 *PRINT    = \&print;
1506 *PRINTF   = \&printf;
1507 *WRITE    = \&syswrite;
1508 *write    = \&syswrite;
1509 *SEEK     = \&seek;
1510 *TELL     = \&tell;
1511 *EOF      = \&eof;
1512 *CLOSE    = \&close;
1513 *BINMODE  = \&binmode;
1514
1515 #*sysread  = \&_notAvailable;
1516 #*syswrite = \&_write;
1517
1518 1;
1519
1520 __END__
1521
1522 =head1 NAME
1523
1524 IO::Compress::Gzip     - Perl interface to write RFC 1952 files/buffers
1525
1526 =head1 SYNOPSIS
1527
1528     use IO::Compress::Gzip qw(gzip $GzipError) ;
1529
1530
1531     my $status = gzip $input => $output [,OPTS]
1532         or die "gzip failed: $GzipError\n";
1533
1534     my $z = new IO::Compress::Gzip $output [,OPTS]
1535         or die "gzip failed: $GzipError\n";
1536
1537     $z->print($string);
1538     $z->printf($format, $string);
1539     $z->write($string);
1540     $z->syswrite($string [, $length, $offset]);
1541     $z->flush();
1542     $z->tell();
1543     $z->eof();
1544     $z->seek($position, $whence);
1545     $z->binmode();
1546     $z->fileno();
1547     $z->newStream();
1548     $z->deflateParams();
1549     $z->close() ;
1550
1551     $GzipError ;
1552
1553     # IO::File mode
1554
1555     print $z $string;
1556     printf $z $format, $string;
1557     syswrite $z, $string [, $length, $offset];
1558     flush $z, ;
1559     tell $z
1560     eof $z
1561     seek $z, $position, $whence
1562     binmode $z
1563     fileno $z
1564     close $z ;
1565
1566
1567 =head1 DESCRIPTION
1568
1569
1570
1571 B<WARNING -- This is a Beta release>.
1572
1573 =over 5
1574
1575 =item * DO NOT use in production code.
1576
1577 =item * The documentation is incomplete in places.
1578
1579 =item * Parts of the interface defined here are tentative.
1580
1581 =item * Please report any problems you find.
1582
1583 =back
1584
1585
1586
1587 This module provides a Perl interface that allows writing compressed
1588 data to files or buffer as defined in RFC 1952.
1589
1590
1591 All the gzip headers defined in RFC 1952 can be created using
1592 this module.
1593
1594
1595
1596
1597 For reading RFC 1952 files/buffers, see the companion module
1598 L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>.
1599
1600
1601 =head1 Functional Interface
1602
1603 A top-level function, C<gzip>, is provided to carry out "one-shot"
1604 compression between buffers and/or files. For finer control over the compression process, see the L</"OO Interface"> section.
1605
1606     use IO::Compress::Gzip qw(gzip $GzipError) ;
1607
1608     gzip $input => $output [,OPTS]
1609         or die "gzip failed: $GzipError\n";
1610
1611     gzip \%hash [,OPTS]
1612         or die "gzip failed: $GzipError\n";
1613
1614 The functional interface needs Perl5.005 or better.
1615
1616
1617 =head2 gzip $input => $output [, OPTS]
1618
1619 If the first parameter is not a hash reference C<gzip> expects
1620 at least two parameters, C<$input> and C<$output>.
1621
1622 =head3 The C<$input> parameter
1623
1624 The parameter, C<$input>, is used to define the source of
1625 the uncompressed data.
1626
1627 It can take one of the following forms:
1628
1629 =over 5
1630
1631 =item A filename
1632
1633 If the C<$input> parameter is a simple scalar, it is assumed to be a
1634 filename. This file will be opened for reading and the input data
1635 will be read from it.
1636
1637 =item A filehandle
1638
1639 If the C<$input> parameter is a filehandle, the input data will be
1640 read from it.
1641 The string '-' can be used as an alias for standard input.
1642
1643 =item A scalar reference
1644
1645 If C<$input> is a scalar reference, the input data will be read
1646 from C<$$input>.
1647
1648 =item An array reference
1649
1650 If C<$input> is an array reference, the input data will be read from each
1651 element of the array in turn. The action taken by C<gzip> with
1652 each element of the array will depend on the type of data stored
1653 in it. You can mix and match any of the types defined in this list,
1654 excluding other array or hash references.
1655 The complete array will be walked to ensure that it only
1656 contains valid data types before any data is compressed.
1657
1658 =item An Input FileGlob string
1659
1660 If C<$input> is a string that is delimited by the characters "<" and ">"
1661 C<gzip> will assume that it is an I<input fileglob string>. The
1662 input is the list of files that match the fileglob.
1663
1664 If the fileglob does not match any files ...
1665
1666 See L<File::GlobMapper|File::GlobMapper> for more details.
1667
1668
1669 =back
1670
1671 If the C<$input> parameter is any other type, C<undef> will be returned.
1672
1673
1674
1675 In addition, if C<$input> is a simple filename, the default values for
1676 two of the gzip header fields created by this function will be sourced
1677 from that file -- the NAME gzip header field will be populated with
1678 the filename itself, and the MTIME header field will be set to the
1679 modification time of the file.
1680 The intention here is to mirror part of the behavior of the gzip
1681 executable.
1682 If you do not want to use these defaults they can be overridden by
1683 explicitly setting the C<Name> and C<Time> options.
1684
1685
1686
1687 =head3 The C<$output> parameter
1688
1689 The parameter C<$output> is used to control the destination of the
1690 compressed data. This parameter can take one of these forms.
1691
1692 =over 5
1693
1694 =item A filename
1695
1696 If the C<$output> parameter is a simple scalar, it is assumed to be a filename.
1697 This file will be opened for writing and the compressed data will be
1698 written to it.
1699
1700 =item A filehandle
1701
1702 If the C<$output> parameter is a filehandle, the compressed data will
1703 be written to it.
1704 The string '-' can be used as an alias for standard output.
1705
1706
1707 =item A scalar reference
1708
1709 If C<$output> is a scalar reference, the compressed data will be stored
1710 in C<$$output>.
1711
1712
1713 =item A Hash Reference
1714
1715 If C<$output> is a hash reference, the compressed data will be written
1716 to C<$output{$input}> as a scalar reference.
1717
1718 When C<$output> is a hash reference, C<$input> must be either a filename or
1719 list of filenames. Anything else is an error.
1720
1721
1722 =item An Array Reference
1723
1724 If C<$output> is an array reference, the compressed data will be pushed
1725 onto the array.
1726
1727 =item An Output FileGlob
1728
1729 If C<$output> is a string that is delimited by the characters "<" and ">"
1730 C<gzip> will assume that it is an I<output fileglob string>. The
1731 output is the list of files that match the fileglob.
1732
1733 When C<$output> is an fileglob string, C<$input> must also be a fileglob
1734 string. Anything else is an error.
1735
1736 =back
1737
1738 If the C<$output> parameter is any other type, C<undef> will be returned.
1739
1740 =head2 gzip \%hash [, OPTS]
1741
1742 If the first parameter is a hash reference, C<\%hash>, this will be used to
1743 define both the source of uncompressed data and to control where the
1744 compressed data is output. Each key/value pair in the hash defines a
1745 mapping between an input filename, stored in the key, and an output
1746 file/buffer, stored in the value. Although the input can only be a filename,
1747 there is more flexibility to control the destination of the compressed
1748 data. This is determined by the type of the value. Valid types are
1749
1750 =over 5
1751
1752 =item undef
1753
1754 If the value is C<undef> the compressed data will be written to the
1755 value as a scalar reference.
1756
1757 =item A filename
1758
1759 If the value is a simple scalar, it is assumed to be a filename. This file will
1760 be opened for writing and the compressed data will be written to it.
1761
1762 =item A filehandle
1763
1764 If the value is a filehandle, the compressed data will be
1765 written to it.
1766 The string '-' can be used as an alias for standard output.
1767
1768
1769 =item A scalar reference
1770
1771 If the value is a scalar reference, the compressed data will be stored
1772 in the buffer that is referenced by the scalar.
1773
1774
1775 =item A Hash Reference
1776
1777 If the value is a hash reference, the compressed data will be written
1778 to C<$hash{$input}> as a scalar reference.
1779
1780 =item An Array Reference
1781
1782 If C<$output> is an array reference, the compressed data will be pushed
1783 onto the array.
1784
1785 =back
1786
1787 Any other type is a error.
1788
1789 =head2 Notes
1790
1791 When C<$input> maps to multiple files/buffers and C<$output> is a single
1792 file/buffer the compressed input files/buffers will all be stored in
1793 C<$output> as a single compressed stream.
1794
1795
1796
1797 =head2 Optional Parameters
1798
1799 Unless specified below, the optional parameters for C<gzip>,
1800 C<OPTS>, are the same as those used with the OO interface defined in the
1801 L</"Constructor Options"> section below.
1802
1803 =over 5
1804
1805 =item AutoClose =E<gt> 0|1
1806
1807 This option applies to any input or output data streams to C<gzip>
1808 that are filehandles.
1809
1810 If C<AutoClose> is specified, and the value is true, it will result in all
1811 input and/or output filehandles being closed once C<gzip> has
1812 completed.
1813
1814 This parameter defaults to 0.
1815
1816
1817
1818 =item -Append =E<gt> 0|1
1819
1820 TODO
1821
1822
1823 =back
1824
1825
1826
1827 =head2 Examples
1828
1829 To read the contents of the file C<file1.txt> and write the compressed
1830 data to the file C<file1.txt.gz>.
1831
1832     use strict ;
1833     use warnings ;
1834     use IO::Compress::Gzip qw(gzip $GzipError) ;
1835
1836     my $input = "file1.txt";
1837     gzip $input => "$input.gz"
1838         or die "gzip failed: $GzipError\n";
1839
1840
1841 To read from an existing Perl filehandle, C<$input>, and write the
1842 compressed data to a buffer, C<$buffer>.
1843
1844     use strict ;
1845     use warnings ;
1846     use IO::Compress::Gzip qw(gzip $GzipError) ;
1847     use IO::File ;
1848
1849     my $input = new IO::File "<file1.txt"
1850         or die "Cannot open 'file1.txt': $!\n" ;
1851     my $buffer ;
1852     gzip $input => \$buffer
1853         or die "gzip failed: $GzipError\n";
1854
1855 To compress all files in the directory "/my/home" that match "*.txt"
1856 and store the compressed data in the same directory
1857
1858     use strict ;
1859     use warnings ;
1860     use IO::Compress::Gzip qw(gzip $GzipError) ;
1861
1862     gzip '</my/home/*.txt>' => '<*.gz>'
1863         or die "gzip failed: $GzipError\n";
1864
1865 and if you want to compress each file one at a time, this will do the trick
1866
1867     use strict ;
1868     use warnings ;
1869     use IO::Compress::Gzip qw(gzip $GzipError) ;
1870
1871     for my $input ( glob "/my/home/*.txt" )
1872     {
1873         my $output = "$input.gz" ;
1874         gzip $input => $output
1875             or die "Error compressing '$input': $GzipError\n";
1876     }
1877
1878
1879 =head1 OO Interface
1880
1881 =head2 Constructor
1882
1883 The format of the constructor for C<IO::Compress::Gzip> is shown below
1884
1885     my $z = new IO::Compress::Gzip $output [,OPTS]
1886         or die "IO::Compress::Gzip failed: $GzipError\n";
1887
1888 It returns an C<IO::Compress::Gzip> object on success and undef on failure.
1889 The variable C<$GzipError> will contain an error message on failure.
1890
1891 If you are running Perl 5.005 or better the object, C<$z>, returned from
1892 IO::Compress::Gzip can be used exactly like an L<IO::File|IO::File> filehandle.
1893 This means that all normal output file operations can be carried out
1894 with C<$z>.
1895 For example, to write to a compressed file/buffer you can use either of
1896 these forms
1897
1898     $z->print("hello world\n");
1899     print $z "hello world\n";
1900
1901 The mandatory parameter C<$output> is used to control the destination
1902 of the compressed data. This parameter can take one of these forms.
1903
1904 =over 5
1905
1906 =item A filename
1907
1908 If the C<$output> parameter is a simple scalar, it is assumed to be a
1909 filename. This file will be opened for writing and the compressed data
1910 will be written to it.
1911
1912 =item A filehandle
1913
1914 If the C<$output> parameter is a filehandle, the compressed data will be
1915 written to it.
1916 The string '-' can be used as an alias for standard output.
1917
1918
1919 =item A scalar reference
1920
1921 If C<$output> is a scalar reference, the compressed data will be stored
1922 in C<$$output>.
1923
1924 =back
1925
1926 If the C<$output> parameter is any other type, C<IO::Compress::Gzip>::new will
1927 return undef.
1928
1929 =head2 Constructor Options
1930
1931 C<OPTS> is any combination of the following options:
1932
1933 =over 5
1934
1935 =item -AutoClose =E<gt> 0|1
1936
1937 This option is only valid when the C<$output> parameter is a filehandle. If
1938 specified, and the value is true, it will result in the C<$output> being closed
1939 once either the C<close> method is called or the C<IO::Compress::Gzip> object is
1940 destroyed.
1941
1942 This parameter defaults to 0.
1943
1944 =item -Append =E<gt> 0|1
1945
1946 Opens C<$output> in append mode.
1947
1948 The behaviour of this option is dependant on the type of C<$output>.
1949
1950 =over 5
1951
1952 =item * A Buffer
1953
1954 If C<$output> is a buffer and C<Append> is enabled, all compressed data will be
1955 append to the end if C<$output>. Otherwise C<$output> will be cleared before
1956 any data is written to it.
1957
1958 =item * A Filename
1959
1960 If C<$output> is a filename and C<Append> is enabled, the file will be opened
1961 in append mode. Otherwise the contents of the file, if any, will be truncated
1962 before any compressed data is written to it.
1963
1964 =item * A Filehandle
1965
1966 If C<$output> is a filehandle, the file pointer will be positioned to the end
1967 of the file via a call to C<seek> before any compressed data is written to it.
1968 Otherwise the file pointer will not be moved.
1969
1970 =back
1971
1972 This parameter defaults to 0.
1973
1974 =item -Merge =E<gt> 0|1
1975
1976 This option is used to compress input data and append it to an existing
1977 compressed data stream in C<$output>. The end result is a single compressed
1978 data stream stored in C<$output>.
1979
1980
1981
1982 It is a fatal error to attempt to use this option when C<$output> is not an RFC
1983 1952 data stream.
1984
1985
1986
1987 There are a number of other limitations with the C<Merge> option:
1988
1989 =over 5
1990
1991 =item 1
1992
1993 This module needs to have been built with zlib 1.2.1 or better to work. A fatal
1994 error will be thrown if C<Merge> is used with an older version of zlib.
1995
1996 =item 2
1997
1998 If C<$output> is a file or a filehandle, it must be seekable.
1999
2000 =back
2001
2002
2003 This parameter defaults to 0.
2004
2005 =item -Level
2006
2007 Defines the compression level used by zlib. The value should either be
2008 a number between 0 and 9 (0 means no compression and 9 is maximum
2009 compression), or one of the symbolic constants defined below.
2010
2011    Z_NO_COMPRESSION
2012    Z_BEST_SPEED
2013    Z_BEST_COMPRESSION
2014    Z_DEFAULT_COMPRESSION
2015
2016 The default is Z_DEFAULT_COMPRESSION.
2017
2018 Note, these constants are not imported by C<IO::Compress::Gzip> by default.
2019
2020     use IO::Compress::Gzip qw(:strategy);
2021     use IO::Compress::Gzip qw(:constants);
2022     use IO::Compress::Gzip qw(:all);
2023
2024 =item -Strategy
2025
2026 Defines the strategy used to tune the compression. Use one of the symbolic
2027 constants defined below.
2028
2029    Z_FILTERED
2030    Z_HUFFMAN_ONLY
2031    Z_RLE
2032    Z_FIXED
2033    Z_DEFAULT_STRATEGY
2034
2035 The default is Z_DEFAULT_STRATEGY.
2036
2037
2038
2039
2040
2041 =item -Mimimal =E<gt> 0|1
2042
2043 If specified, this option will force the creation of the smallest possible
2044 compliant gzip header (which is exactly 10 bytes long) as defined in
2045 RFC 1952.
2046
2047 See the section titled "Compliance" in RFC 1952 for a definition
2048 of the values used for the fields in the gzip header.
2049
2050 All other parameters that control the content of the gzip header will
2051 be ignored if this parameter is set to 1.
2052
2053 This parameter defaults to 0.
2054
2055 =item -Comment =E<gt> $comment
2056
2057 Stores the contents of C<$comment> in the COMMENT field in
2058 the gzip header.
2059 By default, no comment field is written to the gzip file.
2060
2061 If the C<-Strict> option is enabled, the comment can only consist of ISO
2062 8859-1 characters plus line feed.
2063
2064 If the C<-Strict> option is disabled, the comment field can contain any
2065 character except NULL. If any null characters are present, the field
2066 will be truncated at the first NULL.
2067
2068 =item -Name =E<gt> $string
2069
2070 Stores the contents of C<$string> in the gzip NAME header field. If
2071 C<Name> is not specified, no gzip NAME field will be created.
2072
2073 If the C<-Strict> option is enabled, C<$string> can only consist of ISO
2074 8859-1 characters.
2075
2076 If C<-Strict> is disabled, then C<$string> can contain any character
2077 except NULL. If any null characters are present, the field will be
2078 truncated at the first NULL.
2079
2080 =item -Time =E<gt> $number
2081
2082 Sets the MTIME field in the gzip header to $number.
2083
2084 This field defaults to the time the C<IO::Compress::Gzip> object was created
2085 if this option is not specified.
2086
2087 =item -TextFlag =E<gt> 0|1
2088
2089 This parameter controls the setting of the FLG.FTEXT bit in the gzip header. It
2090 is used to signal that the data stored in the gzip file/buffer is probably
2091 text.
2092
2093 The default is 0.
2094
2095 =item -HeaderCRC =E<gt> 0|1
2096
2097 When true this parameter will set the FLG.FHCRC bit to 1 in the gzip header and
2098 set the CRC16 header field to the CRC of the complete gzip header except the
2099 CRC16 field itself.
2100
2101 B<Note> that gzip files created with the C<HeaderCRC> flag set to 1 cannot be
2102 read by most, if not all, of the the standard gunzip utilities, most notably
2103 gzip version 1.2.4. You should therefore avoid using this option if you want to
2104 maximise the portability of your gzip files.
2105
2106 This parameter defaults to 0.
2107
2108 =item -OS_Code =E<gt> $value
2109
2110 Stores C<$value> in the gzip OS header field. A number between 0 and
2111 255 is valid.
2112
2113 If not specified, this parameter defaults to the OS code of the Operating
2114 System this module was built on. The value 3 is used as a catch-all for all
2115 Unix variants and unknown Operating Systems.
2116
2117 =item -ExtraField =E<gt> $data
2118
2119 This parameter allows additional metadata to be stored in the ExtraField in the
2120 gzip header. An RFC1952 compliant ExtraField consists of zero or more
2121 subfields. Each subfield consists of a two byte header followed by the subfield
2122 data.
2123
2124 The list of subfields can be supplied in any of the following formats
2125
2126     -ExtraField => [$id1, $data1,
2127                     $id2, $data2,
2128                      ...
2129                    ]
2130     -ExtraField => [ [$id1 => $data1],
2131                      [$id2 => $data2],
2132                      ...
2133                    ]
2134     -ExtraField => { $id1 => $data1,
2135                      $id2 => $data2,
2136                      ...
2137                    }
2138
2139 Where C<$id1>, C<$id2> are two byte subfield ID's. The second byte of
2140 the ID cannot be 0, unless the C<Strict> option has been disabled.
2141
2142 If you use the hash syntax, you have no control over the order in which
2143 the ExtraSubFields are stored, plus you cannot have SubFields with
2144 duplicate ID.
2145
2146 Alternatively the list of subfields can by supplied as a scalar, thus
2147
2148     -ExtraField => $rawdata
2149
2150 If you use the raw format, and the C<Strict> option is enabled,
2151 C<IO::Compress::Gzip> will check that C<$rawdata> consists of zero or more
2152 conformant sub-fields. When C<Strict> is disabled, C<$rawdata> can
2153 consist of any arbitrary byte stream.
2154
2155 The maximum size of the Extra Field 65535 bytes.
2156
2157 =item -ExtraFlags =E<gt> $value
2158
2159 Sets the XFL byte in the gzip header to C<$value>.
2160
2161 If this option is not present, the value stored in XFL field will be determined
2162 by the setting of the C<Level> option.
2163
2164 If C<Level =E<gt> Z_BEST_SPEED> has been specified then XFL is set to 2.
2165 If C<Level =E<gt> Z_BEST_COMPRESSION> has been specified then XFL is set to 4.
2166 Otherwise XFL is set to 0.
2167
2168
2169
2170 =item -Strict =E<gt> 0|1
2171
2172
2173
2174 C<Strict> will optionally police the values supplied with other options
2175 to ensure they are compliant with RFC1952.
2176
2177 This option is enabled by default.
2178
2179 If C<Strict> is enabled the following behavior will be policed:
2180
2181 =over 5
2182
2183 =item *
2184
2185 The value supplied with the C<Name> option can only contain ISO 8859-1
2186 characters.
2187
2188 =item *
2189
2190 The value supplied with the C<Comment> option can only contain ISO 8859-1
2191 characters plus line-feed.
2192
2193 =item *
2194
2195 The values supplied with the C<-Name> and C<-Comment> options cannot
2196 contain multiple embedded nulls.
2197
2198 =item *
2199
2200 If an C<ExtraField> option is specified and it is a simple scalar,
2201 it must conform to the sub-field structure as defined in RFC1952.
2202
2203 =item *
2204
2205 If an C<ExtraField> option is specified the second byte of the ID will be
2206 checked in each subfield to ensure that it does not contain the reserved
2207 value 0x00.
2208
2209 =back
2210
2211 When C<Strict> is disabled the following behavior will be policed:
2212
2213 =over 5
2214
2215 =item *
2216
2217 The value supplied with C<-Name> option can contain
2218 any character except NULL.
2219
2220 =item *
2221
2222 The value supplied with C<-Comment> option can contain any character
2223 except NULL.
2224
2225 =item *
2226
2227 The values supplied with the C<-Name> and C<-Comment> options can contain
2228 multiple embedded nulls. The string written to the gzip header will
2229 consist of the characters up to, but not including, the first embedded
2230 NULL.
2231
2232 =item *
2233
2234 If an C<ExtraField> option is specified and it is a simple scalar, the
2235 structure will not be checked. The only error is if the length is too big.
2236
2237 =item *
2238
2239 The ID header in an C<ExtraField> sub-field can consist of any two bytes.
2240
2241 =back
2242
2243
2244
2245 =back
2246
2247 =head2 Examples
2248
2249 TODO
2250
2251 =head1 Methods
2252
2253 =head2 print
2254
2255 Usage is
2256
2257     $z->print($data)
2258     print $z $data
2259
2260 Compresses and outputs the contents of the C<$data> parameter. This
2261 has the same behavior as the C<print> built-in.
2262
2263 Returns true if successful.
2264
2265 =head2 printf
2266
2267 Usage is
2268
2269     $z->printf($format, $data)
2270     printf $z $format, $data
2271
2272 Compresses and outputs the contents of the C<$data> parameter.
2273
2274 Returns true if successful.
2275
2276 =head2 syswrite
2277
2278 Usage is
2279
2280     $z->syswrite $data
2281     $z->syswrite $data, $length
2282     $z->syswrite $data, $length, $offset
2283
2284     syswrite $z, $data
2285     syswrite $z, $data, $length
2286     syswrite $z, $data, $length, $offset
2287
2288 Compresses and outputs the contents of the C<$data> parameter.
2289
2290 Returns the number of uncompressed bytes written, or C<undef> if
2291 unsuccessful.
2292
2293 =head2 write
2294
2295 Usage is
2296
2297     $z->write $data
2298     $z->write $data, $length
2299     $z->write $data, $length, $offset
2300
2301 Compresses and outputs the contents of the C<$data> parameter.
2302
2303 Returns the number of uncompressed bytes written, or C<undef> if
2304 unsuccessful.
2305
2306 =head2 flush
2307
2308 Usage is
2309
2310     $z->flush;
2311     $z->flush($flush_type);
2312     flush $z ;
2313     flush $z $flush_type;
2314
2315 Flushes any pending compressed data to the output file/buffer.
2316
2317 This method takes an optional parameter, C<$flush_type>, that controls
2318 how the flushing will be carried out. By default the C<$flush_type>
2319 used is C<Z_FINISH>. Other valid values for C<$flush_type> are
2320 C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is
2321 strongly recommended that you only set the C<flush_type> parameter if
2322 you fully understand the implications of what it does - overuse of C<flush>
2323 can seriously degrade the level of compression achieved. See the C<zlib>
2324 documentation for details.
2325
2326 Returns true on success.
2327
2328
2329 =head2 tell
2330
2331 Usage is
2332
2333     $z->tell()
2334     tell $z
2335
2336 Returns the uncompressed file offset.
2337
2338 =head2 eof
2339
2340 Usage is
2341
2342     $z->eof();
2343     eof($z);
2344
2345
2346
2347 Returns true if the C<close> method has been called.
2348
2349
2350
2351 =head2 seek
2352
2353     $z->seek($position, $whence);
2354     seek($z, $position, $whence);
2355
2356
2357
2358
2359 Provides a sub-set of the C<seek> functionality, with the restriction
2360 that it is only legal to seek forward in the output file/buffer.
2361 It is a fatal error to attempt to seek backward.
2362
2363 Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
2364
2365
2366
2367 The C<$whence> parameter takes one the usual values, namely SEEK_SET,
2368 SEEK_CUR or SEEK_END.
2369
2370 Returns 1 on success, 0 on failure.
2371
2372 =head2 binmode
2373
2374 Usage is
2375
2376     $z->binmode
2377     binmode $z ;
2378
2379 This is a noop provided for completeness.
2380
2381 =head2 fileno
2382
2383     $z->fileno()
2384     fileno($z)
2385
2386 If the C<$z> object is associated with a file, this method will return
2387 the underlying filehandle.
2388
2389 If the C<$z> object is is associated with a buffer, this method will
2390 return undef.
2391
2392 =head2 close
2393
2394     $z->close() ;
2395     close $z ;
2396
2397
2398
2399 Flushes any pending compressed data and then closes the output file/buffer.
2400
2401
2402
2403 For most versions of Perl this method will be automatically invoked if
2404 the IO::Compress::Gzip object is destroyed (either explicitly or by the
2405 variable with the reference to the object going out of scope). The
2406 exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
2407 these cases, the C<close> method will be called automatically, but
2408 not until global destruction of all live objects when the program is
2409 terminating.
2410
2411 Therefore, if you want your scripts to be able to run on all versions
2412 of Perl, you should call C<close> explicitly and not rely on automatic
2413 closing.
2414
2415 Returns true on success, otherwise 0.
2416
2417 If the C<AutoClose> option has been enabled when the IO::Compress::Gzip
2418 object was created, and the object is associated with a file, the
2419 underlying file will also be closed.
2420
2421
2422
2423
2424 =head2 newStream
2425
2426 Usage is
2427
2428     $z->newStream
2429
2430 TODO
2431
2432 =head2 deflateParams
2433
2434 Usage is
2435
2436     $z->deflateParams
2437
2438 TODO
2439
2440 =head1 Importing
2441
2442 A number of symbolic constants are required by some methods in
2443 C<IO::Compress::Gzip>. None are imported by default.
2444
2445 =over 5
2446
2447 =item :all
2448
2449 Imports C<gzip>, C<$GzipError> and all symbolic
2450 constants that can be used by C<IO::Compress::Gzip>. Same as doing this
2451
2452     use IO::Compress::Gzip qw(gzip $GzipError :constants) ;
2453
2454 =item :constants
2455
2456 Import all symbolic constants. Same as doing this
2457
2458     use IO::Compress::Gzip qw(:flush :level :strategy) ;
2459
2460 =item :flush
2461
2462 These symbolic constants are used by the C<flush> method.
2463
2464     Z_NO_FLUSH
2465     Z_PARTIAL_FLUSH
2466     Z_SYNC_FLUSH
2467     Z_FULL_FLUSH
2468     Z_FINISH
2469     Z_BLOCK
2470
2471
2472 =item :level
2473
2474 These symbolic constants are used by the C<Level> option in the constructor.
2475
2476     Z_NO_COMPRESSION
2477     Z_BEST_SPEED
2478     Z_BEST_COMPRESSION
2479     Z_DEFAULT_COMPRESSION
2480
2481
2482 =item :strategy
2483
2484 These symbolic constants are used by the C<Strategy> option in the constructor.
2485
2486     Z_FILTERED
2487     Z_HUFFMAN_ONLY
2488     Z_RLE
2489     Z_FIXED
2490     Z_DEFAULT_STRATEGY
2491
2492 =back
2493
2494 For
2495
2496 =head1 EXAMPLES
2497
2498 TODO
2499
2500
2501
2502
2503
2504
2505 =head1 SEE ALSO
2506
2507 L<Compress::Zlib>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::AnyInflate>
2508
2509 L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
2510
2511 L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>,
2512 L<IO::Zlib|IO::Zlib>
2513
2514 For RFC 1950, 1951 and 1952 see
2515 F<http://www.faqs.org/rfcs/rfc1950.html>,
2516 F<http://www.faqs.org/rfcs/rfc1951.html> and
2517 F<http://www.faqs.org/rfcs/rfc1952.html>
2518
2519 The primary site for the gzip program is F<http://www.gzip.org>.
2520
2521 =head1 AUTHOR
2522
2523 The I<IO::Compress::Gzip> module was written by Paul Marquess,
2524 F<pmqs@cpan.org>. The latest copy of the module can be
2525 found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>.
2526
2527 The I<zlib> compression library was written by Jean-loup Gailly
2528 F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
2529
2530 The primary site for the I<zlib> compression library is
2531 F<http://www.zlib.org>.
2532
2533 =head1 MODIFICATION HISTORY
2534
2535 See the Changes file.
2536
2537 =head1 COPYRIGHT AND LICENSE
2538
2539
2540 Copyright (c) 2005 Paul Marquess. All rights reserved.
2541 This program is free software; you can redistribute it and/or
2542 modify it under the same terms as Perl itself.
2543
2544
2545
2546