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