diff options
author | Craig A. Berry <craigberry@mac.com> | 2007-04-24 03:18:34 +0000 |
---|---|---|
committer | Craig A. Berry <craigberry@mac.com> | 2007-04-24 03:18:34 +0000 |
commit | 1e6aeec812b843a7ede56e2466b96a7284b7f423 (patch) | |
tree | df44b9478e2bbf66164cf612bd2d2f2c62910fe8 /ext/IO_Compress_Zlib | |
parent | 009d90df4e17a4157d8fe825678a18dc3e97d437 (diff) | |
download | perl-1e6aeec812b843a7ede56e2466b96a7284b7f423.tar.gz |
Reduce directory depth for IO::Compress modules.
p4raw-id: //depot/perl@31047
Diffstat (limited to 'ext/IO_Compress_Zlib')
83 files changed, 16305 insertions, 0 deletions
diff --git a/ext/IO_Compress_Zlib/Changes b/ext/IO_Compress_Zlib/Changes new file mode 100644 index 0000000000..e5c95f87a3 --- /dev/null +++ b/ext/IO_Compress_Zlib/Changes @@ -0,0 +1,121 @@ +CHANGES +------- + + 2.004 3 March 2007 + + * IO::Compress::Zip + + - Added Zip64 documentation. + + - Fixed extended timestamp. + Creation time isn't available in Unix so only store the + modification time and the last access time in the extended field. + + - Fixed file mode. + + - Added ExtAttr option to control the value of the "external file + attributes" field in the central directory. + + - Added Unix2 extended attribute ("Ux"). + This stores the UID & GID. + + * IO::Compress::Gzip + + - Fixed 050interop-gzip.t for Windows + + 2.003 2 January 2007 + + * Added explicit version checking + + 2.002 29 December 2006 + + * Documentation updates. + + 2.001 1 November 2006 + + * Remove beta status. + + 2.000_14 26 October 2006 + + * IO::Uncompress::Deflate + Beefed up the magic signature check. Means less false positives + when auto-detecting the compression type. + + * IO::Uncompress::UnZip + Tighten up the zip64 extra field processing to cope with the case + wheere only some of the local header fields are superceeded. + + * IO::Uncompress::AnyInflate + Remove raw-deflate (RFC 1951) from the default list of compressors + to check. + It can still be included if the new RawInflate parameter is + supplied. + This change was made because the only way to tell if content is + raw-deflate is to attempt to uncompress it - a few false positives + have popped up recently, which suggests that auto-detecting raw + deflate is far from perfect. + The equivalent change has been made to IO::Uncompress::AnyUncompress. + [Core patch #28445] + + 2.000_13 20 June 2006 + + * Preliminary support for reading zip files with zip64 members. + + 2.000_12 3 May 2006 + + * Moved the code for creating and parsing the gzip extra field into + IO::Compress::Zlib::Extra.pm so that IO::Compress::Zip & + IO::Uncompress::Unzip can use it as well. + + * Added ExtraFieldLocal & ExtraFieldCentral options to IO::Compress::Zip. + These allow the creation of user-defined extra fields in the local + and central headers, just like the ExtraField option in + IO::Compress::Gzip. + + * Moved the zip constants into IO::Compress::Zip::Constants + + * Added exTime option to IO::Compress::Zip. + This allows creation of the extended timestamp extra field. + + * Added Minimal option to IO::Compress::Zip. + This disables the creation of all extended fields. + + * Added TextFlag option to IO::Compress::Zip. + + * Documented Comment and ZipComment options in IO::Compress::Zip. + + 2.000_11 10 April 2006 + + * Updated Documentation for zip modules. + + * Changed IO::Compress::Zip 'Store' option to 'Method' and added + symbolic constants ZIP_CM_STORE, ZIP_CM_DEFLATE and ZIP_CM_BZIP2 to + allow the compression method to be picked by the user. + + * Added support to allow bzip2 compressed data to be written/read + with IO::Compress::Zip and IO::Uncompress::Unzip. + + * Beefed up 050interop-gzip.t to check that the external gzip command + works as expected before starting the tests. This means that + this test harness will just be skipped on problematic systems. + + * Merged core patch 27565 from Steve Peters. This works around a + problem with gzip on OpenBSD where it doesn't seem to like + compressing files < 10 bytes long. + + 2.000_10 13 March 2006 + + * Documentation updates. + + 2.000_09 3 March 2006 + + * Released to CPAN. + + 2.000_08 2 March 2006 + + * Split IO::Compress::Zlib into its own distribution. + + * Beefed up support for zip/unzip + + + diff --git a/ext/IO_Compress_Zlib/Makefile.PL b/ext/IO_Compress_Zlib/Makefile.PL new file mode 100644 index 0000000000..4d38fc7fa9 --- /dev/null +++ b/ext/IO_Compress_Zlib/Makefile.PL @@ -0,0 +1,48 @@ +#! perl -w + +use strict ; +require 5.004 ; + +$::VERSION = '2.004' ; + +use private::MakeUtil; +use ExtUtils::MakeMaker 5.16 ; + +UpDowngrade(getPerlFiles('MANIFEST')) + unless $ENV{PERL_CORE}; + +WriteMakefile( + NAME => 'IO::Compress::Zlib', + VERSION_FROM => 'lib/IO/Compress/Gzip.pm', + 'dist' => { COMPRESS => 'gzip', + TARFLAGS => '-chvf', + SUFFIX => 'gz', + DIST_DEFAULT => 'MyTrebleCheck tardist', + }, + + ( + $ENV{SKIP_FOR_CORE} + ? (MAN3PODS => {}) + : (PREREQ_PM => { 'Compress::Raw::Zlib' => $::VERSION, + 'IO::Compress::Base' => $::VERSION, + 'IO::Uncompress::Base' => $::VERSION, + $] >= 5.005 && $] < 5.006 + ? ('File::BSDGlob' => 0) + : () } + ) + ), + + ( + $] >= 5.005 + ? (ABSTRACT => 'Perl interface to zlib', + AUTHOR => 'Paul Marquess <pmqs@cpan.org>') + : () + ), + + ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? + ('LICENSE' => 'perl') : ()), + +) ; + +# end of file Makefile.PL + diff --git a/ext/IO_Compress_Zlib/README b/ext/IO_Compress_Zlib/README new file mode 100644 index 0000000000..d0e48d4248 --- /dev/null +++ b/ext/IO_Compress_Zlib/README @@ -0,0 +1,157 @@ + + IO::Compress::Zlib + + Version 2.004 + + 3rd March 2007 + + + Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + This program is free software; you can redistribute it + and/or modify it under the same terms as Perl itself. + + + + +DESCRIPTION +----------- + + +This module provides a Perl interface to allow reading and writing of RFC +1950, 1951, 1952 (i.e. gzip) and zip files/buffers. + + + + + +PREREQUISITES +------------- + +Before you can build IO::Compress::Zlib you need to have the following +installed on your system: + + + * Perl 5.004 or better. + * Compress::Raw::Zlib + * IO::Compress::Base + + + + + +BUILDING THE MODULE +------------------- + +Assuming you have met all the prerequisites, the module can now be built +using this sequence of commands: + + perl Makefile.PL + make + make test + + + +INSTALLATION +------------ + +To install IO::Compress::Zlib, run the command below: + + make install + + + + + +TROUBLESHOOTING +--------------- + + + + + + + + + +The t/020isize Test Suite +------------------------ + +This test suite checks that IO::Compress::Zlib can cope with gzip files +that are larger than 2^32 bytes. + +By default these test are NOT run when you do a "make test". If you +really want to run them, you need to execute "make longtest". + +Be warned though -- this test suite can take hours to run on a slow box. + +Also, due to the way the tests are constructed, some architectures will +run out of memory during this test. This should not be considered a bug +in the IO::Compress::Zlib module. + + + + +FEEDBACK +-------- + +How to report a problem with IO::Compress::Zlib. + +To help me help you, I need all of the following information: + + 1. The Versions of everything relevant. + This includes: + + a. The *complete* output from running this + + perl -V + + Do not edit the output in any way. + Note, I want you to run "perl -V" and NOT "perl -v". + + If your perl does not understand the "-V" option it is too + old. This module needs Perl version 5.004 or better. + + b. The version of IO::Compress::Zlib you have. + If you have successfully installed IO::Compress::Zlib, this one-liner + will tell you: + + perl -MIO::Compress::Zlib -e 'print qq[ver $IO::Compress::Zlib::VERSION\n]' + + If you areplete* output from running this + + perl -V + + Do not edit the output in any way. + Note, I want you to run "perl -V" and NOT "perl -v". + + If your perl does not understand the "-V" option it is too + old. This module needs Perl version 5.004 or better. + + b. The version of IO::Compress::Zlib you have. + If you have successfully installed IO::Compress::Zlib, this one-liner + will tell you: + + perl -MIO::Compress::Zlib -e 'print qq[ver $IO::Compress::Zlib::VERSION\n]' + + If you are running windows use this + + perl -MIO::Compress::Zlib -e "print qq[ver $IO::Compress::Zlib::VERSION\n]" + + If you haven't installed IO::Compress::Zlib then search IO::Compress::Zlib.pm + for a line like this: + + $VERSION = "1.05" ; + + + + 2. If you are having problems building IO::Compress::Zlib, send me a + complete log of what happened. Start by unpacking the IO::Compress::Zlib + module into a fresh directory and keep a log of all the steps + + [edit config.in, if necessary] + perl Makefile.PL + make + make test TEST_VERBOSE=1 + + +Paul Marquess <pmqs@cpan.org> diff --git a/ext/IO_Compress_Zlib/examples/gzappend b/ext/IO_Compress_Zlib/examples/gzappend new file mode 100644 index 0000000000..a4a60a9aad --- /dev/null +++ b/ext/IO_Compress_Zlib/examples/gzappend @@ -0,0 +1,24 @@ +#!/usr/local/bin/perl + +use IO::Compress::Gzip qw( $GzipError ); +use strict ; +use warnings ; + +die "Usage: gzappend gz-file file...\n" + unless @ARGV ; + + +my $output = shift @ARGV ; + +@ARGV = '-' unless @ARGV ; + +my $gz = new IO::Compress::Gzip $output, Merge => 1 + or die "Cannot open $output: $GzipError\n" ; + +$gz->write( [@ARGV] ) + or die "Cannot open $output: $GzipError\n" ; + +$gz->close; + + + diff --git a/ext/IO_Compress_Zlib/examples/gzcat b/ext/IO_Compress_Zlib/examples/gzcat new file mode 100755 index 0000000000..5572bae959 --- /dev/null +++ b/ext/IO_Compress_Zlib/examples/gzcat @@ -0,0 +1,29 @@ +#!/usr/local/bin/perl + +use IO::Uncompress::Gunzip qw( $GunzipError ); +use strict ; +use warnings ; + +#die "Usage: gzcat file...\n" +# unless @ARGV ; + +my $file ; +my $buffer ; +my $s; + +@ARGV = '-' unless @ARGV ; + +foreach $file (@ARGV) { + + my $gz = new IO::Uncompress::Gunzip $file + or die "Cannot open $file: $GunzipError\n" ; + + print $buffer + while ($s = $gz->read($buffer)) > 0 ; + + die "Error reading from $file: $GunzipError\n" + if $s < 0 ; + + $gz->close() ; +} + diff --git a/ext/IO_Compress_Zlib/examples/gzgrep b/ext/IO_Compress_Zlib/examples/gzgrep new file mode 100755 index 0000000000..33820ba064 --- /dev/null +++ b/ext/IO_Compress_Zlib/examples/gzgrep @@ -0,0 +1,40 @@ +#!/usr/bin/perl + +use strict ; +use warnings ; +use IO::Uncompress::Gunzip qw($GunzipError); + +die "Usage: gzgrep pattern [file...]\n" + unless @ARGV >= 1; + +my $pattern = shift ; +my $file ; + +@ARGV = '-' unless @ARGV ; + +foreach $file (@ARGV) { + my $gz = new IO::Uncompress::Gunzip $file + or die "Cannot uncompress $file: $GunzipError\n" ; + + while (<$gz>) { + print if /$pattern/ ; + } + + die "Error reading from $file: $GunzipError\n" + if $GunzipError ; +} + +__END__ +foreach $file (@ARGV) { + my $gz = gzopen($file, "rb") + or die "Cannot open $file: $gzerrno\n" ; + + while ($gz->gzreadline($_) > 0) { + print if /$pattern/ ; + } + + die "Error reading from $file: $gzerrno\n" + if $gzerrno != Z_STREAM_END ; + + $gz->gzclose() ; +} diff --git a/ext/IO_Compress_Zlib/examples/gzstream b/ext/IO_Compress_Zlib/examples/gzstream new file mode 100755 index 0000000000..9d03bc5749 --- /dev/null +++ b/ext/IO_Compress_Zlib/examples/gzstream @@ -0,0 +1,24 @@ +#!/usr/local/bin/perl + +use strict ; +use warnings ; +use IO::Compress::Gzip qw(gzip $GzipError); + +gzip '-' => '-', Minimal => 1 + or die "gzstream: $GzipError\n" ; + +#exit 0; + +__END__ + +#my $gz = new IO::Compress::Gzip *STDOUT +my $gz = new IO::Compress::Gzip '-' + or die "gzstream: Cannot open stdout as gzip stream: $GzipError\n" ; + +while (<>) { + $gz->write($_) + or die "gzstream: Error writing gzip output stream: $GzipError\n" ; +} + +$gz->close + or die "gzstream: Error closing gzip output stream: $GzipError\n" ; diff --git a/ext/IO_Compress_Zlib/examples/unzip b/ext/IO_Compress_Zlib/examples/unzip new file mode 100644 index 0000000000..417a9d28a8 --- /dev/null +++ b/ext/IO_Compress_Zlib/examples/unzip @@ -0,0 +1,69 @@ + +use strict; +use warnings; + +use IO::File; +use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError); + +die "Usage: zipcat file" + if @ARGV != 1 ; + +my $file = $ARGV[0] ; + +my $fh = new IO::File "<$file" + or die "Cannot open '$file': $!\n"; + +while () +{ + my $FIXED_HEADER_LENGTH = 30 ; + my $sig; + my $buffer; + + my $x ; + ($x = $fh->read($buffer, $FIXED_HEADER_LENGTH)) == $FIXED_HEADER_LENGTH + or die "Truncated file top: $x $!\n"; + + my $signature = unpack ("V", substr($buffer, 0, 4)); + + last unless $signature == 0x04034b50; + + my $compressedMethod = unpack ("v", substr($buffer, 8, 2)); + my $compressedLength = unpack ("V", substr($buffer, 18, 4)); + #my $uncompressedLength = unpack ("V", substr($buffer, 22, 4)); + my $filename_length = unpack ("v", substr($buffer, 26, 2)); + my $extra_length = unpack ("v", substr($buffer, 28, 2)); + + warn "Compressed Length $compressedLength\n"; + my $filename ; + $fh->read($filename, $filename_length) == $filename_length + or die "Truncated file\n"; + + $fh->read($buffer, $extra_length) == $extra_length + or die "Truncated file\n"; + + if ($compressedMethod != 8 && $compressedMethod != 0) + { + warn "Skipping file '$filename' - not deflated $compressedMethod\n"; + $fh->read($buffer, $compressedLength) == $compressedLength + or die "Truncated file\n"; + next; + } + + next if $compressedLength == 0; + + warn "Writing file '$filename' $compressedMethod\n"; + + mkpath basename $filename; + + rawinflate $fh => $filename, + Transparent => 1, + InputLength => $compressedLength + or die "Error uncompressing $file [$filename]: $RawInflateError\n" ; +} + +sub decodeLocalFileHeader +{ + my $buffer = shift ; +} + + diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/Adapter/Deflate.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/Adapter/Deflate.pm new file mode 100644 index 0000000000..1937c7ccbe --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/Adapter/Deflate.pm @@ -0,0 +1,165 @@ +package IO::Compress::Adapter::Deflate ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.004 qw(:Status); + +use Compress::Raw::Zlib 2.004 qw(Z_OK Z_FINISH MAX_WBITS) ; +our ($VERSION); + +$VERSION = '2.004'; + +sub mkCompObject +{ + my $crc32 = shift ; + my $adler32 = shift ; + my $level = shift ; + my $strategy = shift ; + + my ($def, $status) = new Compress::Raw::Zlib::Deflate + -AppendOutput => 1, + -CRC32 => $crc32, + -ADLER32 => $adler32, + -Level => $level, + -Strategy => $strategy, + -WindowBits => - MAX_WBITS; + + return (undef, "Cannot create Deflate object: $status", $status) + if $status != Z_OK; + + return bless {'Def' => $def, + 'Error' => '', + } ; +} + +sub compr +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->deflate($_[0], $_[1]) ; + $self->{ErrorNo} = $status; + + if ($status != Z_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + +sub flush +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $opt = $_[1] || Z_FINISH; + my $status = $def->flush($_[0], $opt); + $self->{ErrorNo} = $status; + + if ($status != Z_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; + +} + +sub close +{ + my $self = shift ; + + my $def = $self->{Def}; + + $def->flush($_[0], Z_FINISH) + if defined $def ; +} + +sub reset +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->deflateReset() ; + $self->{ErrorNo} = $status; + if ($status != Z_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + +sub deflateParams +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->deflateParams(@_); + $self->{ErrorNo} = $status; + if ($status != Z_OK) + { + $self->{Error} = "deflateParams Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + + + +#sub total_out +#{ +# my $self = shift ; +# $self->{Def}->total_out(); +#} +# +#sub total_in +#{ +# my $self = shift ; +# $self->{Def}->total_in(); +#} + +sub compressedBytes +{ + my $self = shift ; + + $self->{Def}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Def}->uncompressedBytes(); +} + + + + +sub crc32 +{ + my $self = shift ; + $self->{Def}->crc32(); +} + +sub adler32 +{ + my $self = shift ; + $self->{Def}->adler32(); +} + + +1; + +__END__ + diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/Adapter/Identity.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/Adapter/Identity.pm new file mode 100644 index 0000000000..596b670d4c --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/Adapter/Identity.pm @@ -0,0 +1,101 @@ +package IO::Compress::Adapter::Identity ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.004 qw(:Status); +our ($VERSION); + +$VERSION = '2.004'; + +sub mkCompObject +{ + my $level = shift ; + my $strategy = shift ; + + return bless { + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + 'ErrorNo' => 0, + } ; +} + +sub compr +{ + my $self = shift ; + + if (defined ${ $_[0] } && length ${ $_[0] }) { + $self->{CompSize} += length ${ $_[0] } ; + $self->{UnCompSize} = $self->{CompSize} ; + + if ( ref $_[1] ) + { ${ $_[1] } .= ${ $_[0] } } + else + { $_[1] .= ${ $_[0] } } + } + + return STATUS_OK ; +} + +sub flush +{ + my $self = shift ; + + return STATUS_OK; +} + +sub close +{ + my $self = shift ; + + return STATUS_OK; +} + +sub reset +{ + my $self = shift ; + + $self->{CompSize} = 0; + $self->{UnCompSize} = 0; + + return STATUS_OK; +} + +sub deflateParams +{ + my $self = shift ; + + return STATUS_OK; +} + +#sub total_out +#{ +# my $self = shift ; +# return $self->{UnCompSize} ; +#} +# +#sub total_in +#{ +# my $self = shift ; +# return $self->{UnCompSize} ; +#} + +sub compressedBytes +{ + my $self = shift ; + return $self->{UnCompSize} ; +} + +sub uncompressedBytes +{ + my $self = shift ; + return $self->{UnCompSize} ; +} + +1; + + +__END__ + diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/Deflate.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/Deflate.pm new file mode 100644 index 0000000000..0015505a54 --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/Deflate.pm @@ -0,0 +1,1000 @@ +package IO::Compress::Deflate ; + +use strict ; +use warnings; +use bytes; + +require Exporter ; + +use IO::Compress::RawDeflate 2.004 ; + +use Compress::Raw::Zlib 2.004 ; +use IO::Compress::Zlib::Constants 2.004 ; +use IO::Compress::Base::Common 2.004 qw(createSelfTiedObject); + + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError); + +$VERSION = '2.004'; +$DeflateError = ''; + +@ISA = qw(Exporter IO::Compress::RawDeflate); +@EXPORT_OK = qw( $DeflateError deflate ) ; +%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + +sub new +{ + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$DeflateError); + return $obj->_create(undef, @_); +} + +sub deflate +{ + my $obj = createSelfTiedObject(undef, \$DeflateError); + return $obj->_def(@_); +} + + +sub bitmask($$$$) +{ + my $into = shift ; + my $value = shift ; + my $offset = shift ; + my $mask = shift ; + + return $into | (($value & $mask) << $offset ) ; +} + +sub mkDeflateHdr($$$;$) +{ + my $method = shift ; + my $cinfo = shift; + my $level = shift; + my $fdict_adler = shift ; + + my $cmf = 0; + my $flg = 0; + my $fdict = 0; + $fdict = 1 if defined $fdict_adler; + + $cmf = bitmask($cmf, $method, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS); + $cmf = bitmask($cmf, $cinfo, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS); + + $flg = bitmask($flg, $fdict, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS); + $flg = bitmask($flg, $level, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS); + + my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ; + $flg = bitmask($flg, $fcheck, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS); + + my $hdr = pack("CC", $cmf, $flg) ; + $hdr .= pack("N", $fdict_adler) if $fdict ; + + return $hdr; +} + +sub mkHeader +{ + my $self = shift ; + my $param = shift ; + + my $level = $param->value('Level'); + my $strategy = $param->value('Strategy'); + + my $lflag ; + $level = 6 + if $level == Z_DEFAULT_COMPRESSION ; + + if (ZLIB_VERNUM >= 0x1210) + { + if ($strategy >= Z_HUFFMAN_ONLY || $level < 2) + { $lflag = ZLIB_FLG_LEVEL_FASTEST } + elsif ($level < 6) + { $lflag = ZLIB_FLG_LEVEL_FAST } + elsif ($level == 6) + { $lflag = ZLIB_FLG_LEVEL_DEFAULT } + else + { $lflag = ZLIB_FLG_LEVEL_SLOWEST } + } + else + { + $lflag = ($level - 1) >> 1 ; + $lflag = 3 if $lflag > 3 ; + } + + #my $wbits = (MAX_WBITS - 8) << 4 ; + my $wbits = 7; + mkDeflateHdr(ZLIB_CMF_CM_DEFLATED, $wbits, $lflag); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift; + + $got->value('ADLER32' => 1); + return 1 ; +} + + +sub mkTrailer +{ + my $self = shift ; + return pack("N", *$self->{Compress}->adler32()) ; +} + +sub mkFinalTrailer +{ + return ''; +} + +#sub newHeader +#{ +# my $self = shift ; +# return *$self->{Header}; +#} + +sub getExtraParams +{ + my $self = shift ; + return $self->getZlibParams(), +} + +sub getInverseClass +{ + return ('IO::Uncompress::Inflate', + \$IO::Uncompress::Inflate::InflateError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $file = shift ; + +} + + + +1; + +__END__ + +=head1 NAME + + + +IO::Compress::Deflate - Write RFC 1950 files/buffers + + + +=head1 SYNOPSIS + + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + + my $status = deflate $input => $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + my $z = new IO::Compress::Deflate $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $DeflateError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1950. + + + + + + + + + + + +For reading RFC 1950 files/buffers, see the companion module +L<IO::Uncompress::Inflate|IO::Uncompress::Inflate>. + + +=head1 Functional Interface + +A top-level function, C<deflate>, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L</"OO Interface"> +section. + + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + deflate $input => $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 deflate $input => $output [, OPTS] + + +C<deflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, each element in the array must be a +filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<deflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<deflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + + + +=head2 Notes + + + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the input files/buffers will be stored +in C<$output> as a concatenated series of compressed data streams. + + + + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<deflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<deflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<deflate> has +completed. + +This parameter defaults to 0. + + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + + + + + +=item C<< Append => 0|1 >> + +TODO + + + +=back + + + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.1950>. + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + my $input = "file1.txt"; + deflate $input => "$input.1950" + or die "deflate failed: $DeflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + deflate $input => \$buffer + or die "deflate failed: $DeflateError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + deflate '</my/home/*.txt>' => '<*.1950>' + or die "deflate failed: $DeflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.1950" ; + deflate $input => $output + or die "Error compressing '$input': $DeflateError\n"; + } + + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::Deflate> is shown below + + my $z = new IO::Compress::Deflate $output [,OPTS] + or die "IO::Compress::Deflate failed: $DeflateError\n"; + +It returns an C<IO::Compress::Deflate> object on success and undef on failure. +The variable C<$DeflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Deflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::Deflate>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C<close> method is called or the C<IO::Compress::Deflate> +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data +will be append to the end if C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C<seek> before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + + + + + +=item C<< Merge => 0|1 >> + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + + + +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1950 data stream. + + + +There are a number of other limitations with the C<Merge> option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A +fatal error will be thrown if C<Merge> is used with an older version of +zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + + +This parameter defaults to 0. + + + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::Deflate> by default. + + use IO::Compress::Deflate qw(:strategy); + use IO::Compress::Deflate qw(:constants); + use IO::Compress::Deflate qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + + + + + + +=item C<< Strict => 0|1 >> + + + +This is a placeholder option. + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + + $z->flush; + $z->flush($flush_type); + + +Flushes any pending compressed data to the output file/buffer. + + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + + +Returns true on success. + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the C<close> method has been called. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + +This method always returns C<undef> when compressing. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Flushes any pending compressed data and then closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Deflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::Deflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the the options that are available when creating +the C<$z> object. + +See the L</"Constructor Options"> section for more details. + + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + + +=head1 Importing + + +A number of symbolic constants are required by some methods in +C<IO::Compress::Deflate>. None are imported by default. + + + +=over 5 + +=item :all + + +Imports C<deflate>, C<$DeflateError> and all symbolic +constants that can be used by C<IO::Compress::Deflate>. Same as doing this + + use IO::Compress::Deflate qw(deflate $DeflateError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + + use IO::Compress::Deflate qw(:flush :level :strategy) ; + + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + + + + +=back + +For + +=head1 EXAMPLES + +TODO + + + + + + + + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + + + + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/Gzip.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/Gzip.pm new file mode 100644 index 0000000000..5d1656447d --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/Gzip.pm @@ -0,0 +1,1315 @@ + +package IO::Compress::Gzip ; + +require 5.004 ; + +use strict ; +use warnings; +use bytes; + + +use IO::Compress::RawDeflate 2.004 ; + +use Compress::Raw::Zlib 2.004 ; +use IO::Compress::Base::Common 2.004 qw(:Status :Parse createSelfTiedObject); +use IO::Compress::Gzip::Constants 2.004 ; +use IO::Compress::Zlib::Extra 2.004 ; + +BEGIN +{ + if (defined &utf8::downgrade ) + { *noUTF8 = \&utf8::downgrade } + else + { *noUTF8 = sub {} } +} + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError); + +$VERSION = '2.004'; +$GzipError = '' ; + +@ISA = qw(Exporter IO::Compress::RawDeflate); +@EXPORT_OK = qw( $GzipError gzip ) ; +%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +sub new +{ + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$GzipError); + + $obj->_create(undef, @_); +} + + +sub gzip +{ + my $obj = createSelfTiedObject(undef, \$GzipError); + return $obj->_def(@_); +} + +#sub newHeader +#{ +# my $self = shift ; +# #return GZIP_MINIMUM_HEADER ; +# return $self->mkHeader(*$self->{Got}); +#} + +sub getExtraParams +{ + my $self = shift ; + + return ( + # zlib behaviour + $self->getZlibParams(), + + # Gzip header fields + 'Minimal' => [0, 1, Parse_boolean, 0], + 'Comment' => [0, 1, Parse_any, undef], + 'Name' => [0, 1, Parse_any, undef], + 'Time' => [0, 1, Parse_any, undef], + 'TextFlag' => [0, 1, Parse_boolean, 0], + 'HeaderCRC' => [0, 1, Parse_boolean, 0], + 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code], + 'ExtraField'=> [0, 1, Parse_any, undef], + 'ExtraFlags'=> [0, 1, Parse_any, undef], + + ); +} + + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gzip always needs crc32 + $got->value('CRC32' => 1); + + return 1 + if $got->value('Merge') ; + + my $strict = $got->value('Strict') ; + + + { + if (! $got->parsed('Time') ) { + # Modification time defaults to now. + $got->value('Time' => time) ; + } + + # Check that the Name & Comment don't have embedded NULLs + # Also check that they only contain ISO 8859-1 chars. + if ($got->parsed('Name') && defined $got->value('Name')) { + my $name = $got->value('Name'); + + return $self->saveErrorString(undef, "Null Character found in Name", + Z_DATA_ERROR) + if $strict && $name =~ /\x00/ ; + + return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Name", + Z_DATA_ERROR) + if $strict && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; + } + + if ($got->parsed('Comment') && defined $got->value('Comment')) { + my $comment = $got->value('Comment'); + + return $self->saveErrorString(undef, "Null Character found in Comment", + Z_DATA_ERROR) + if $strict && $comment =~ /\x00/ ; + + return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment", + Z_DATA_ERROR) + if $strict && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o; + } + + if ($got->parsed('OS_Code') ) { + my $value = $got->value('OS_Code'); + + return $self->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'") + if $value < 0 || $value > 255 ; + + } + + # gzip only supports Deflate at present + $got->value('Method' => Z_DEFLATED) ; + + if ( ! $got->parsed('ExtraFlags')) { + $got->value('ExtraFlags' => 2) + if $got->value('Level') == Z_BEST_SPEED ; + $got->value('ExtraFlags' => 4) + if $got->value('Level') == Z_BEST_COMPRESSION ; + } + + my $data = $got->value('ExtraField') ; + if (defined $data) { + my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, $strict, 1) ; + return $self->saveErrorString(undef, "Error with ExtraField Parameter: $bad", Z_DATA_ERROR) + if $bad ; + + $got->value('ExtraField', $data) ; + } + } + + return 1; +} + +sub mkTrailer +{ + my $self = shift ; + return pack("V V", *$self->{Compress}->crc32(), + *$self->{UnCompSize}->get32bit()); +} + +sub getInverseClass +{ + return ('IO::Uncompress::Gunzip', + \$IO::Uncompress::Gunzip::GunzipError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $filename = shift ; + + my $defaultTime = (stat($filename))[9] ; + + $params->value('Name' => $filename) + if ! $params->parsed('Name') ; + + $params->value('Time' => $defaultTime) + if ! $params->parsed('Time') ; +} + + +sub mkHeader +{ + my $self = shift ; + my $param = shift ; + + # stort-circuit if a minimal header is requested. + return GZIP_MINIMUM_HEADER if $param->value('Minimal') ; + + # METHOD + my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ; + + # FLAGS + my $flags = GZIP_FLG_DEFAULT ; + $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ; + $flags |= GZIP_FLG_FHCRC if $param->value('HeaderCRC') ; + $flags |= GZIP_FLG_FEXTRA if $param->wantValue('ExtraField') ; + $flags |= GZIP_FLG_FNAME if $param->wantValue('Name') ; + $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ; + + # MTIME + my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ; + + # EXTRA FLAGS + my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT); + + # OS CODE + my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ; + + + my $out = pack("C4 V C C", + GZIP_ID1, # ID1 + GZIP_ID2, # ID2 + $method, # Compression Method + $flags, # Flags + $time, # Modification Time + $extra_flags, # Extra Flags + $os_code, # Operating System Code + ) ; + + # EXTRA + if ($flags & GZIP_FLG_FEXTRA) { + my $extra = $param->value('ExtraField') ; + $out .= pack("v", length $extra) . $extra ; + } + + # NAME + if ($flags & GZIP_FLG_FNAME) { + my $name .= $param->value('Name') ; + $name =~ s/\x00.*$//; + $out .= $name ; + # Terminate the filename with NULL unless it already is + $out .= GZIP_NULL_BYTE + if !length $name or + substr($name, 1, -1) ne GZIP_NULL_BYTE ; + } + + # COMMENT + if ($flags & GZIP_FLG_FCOMMENT) { + my $comment .= $param->value('Comment') ; + $comment =~ s/\x00.*$//; + $out .= $comment ; + # Terminate the comment with NULL unless it already is + $out .= GZIP_NULL_BYTE + if ! length $comment or + substr($comment, 1, -1) ne GZIP_NULL_BYTE; + } + + # HEADER CRC + $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ; + + noUTF8($out); + + return $out ; +} + +sub mkFinalTrailer +{ + return ''; +} + +1; + +__END__ + +=head1 NAME + + + +IO::Compress::Gzip - Write RFC 1952 files/buffers + + + +=head1 SYNOPSIS + + use IO::Compress::Gzip qw(gzip $GzipError) ; + + + my $status = gzip $input => $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + my $z = new IO::Compress::Gzip $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $GzipError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1952. + + + + + +All the gzip headers defined in RFC 1952 can be created using +this module. + + + + + + + +For reading RFC 1952 files/buffers, see the companion module +L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>. + + +=head1 Functional Interface + +A top-level function, C<gzip>, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L</"OO Interface"> +section. + + use IO::Compress::Gzip qw(gzip $GzipError) ; + + gzip $input => $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 gzip $input => $output [, OPTS] + + +C<gzip> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, each element in the array must be a +filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<gzip> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + +In addition, if C<$input> is a simple filename, the default values for +the C<Name> and C<Time> options will be sourced from that file. + +If you do not want to use these defaults they can be overridden by +explicitly setting the C<Name> and C<Time> options or by setting the +C<Minimal> parameter. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<gzip> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + + + +=head2 Notes + + + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the input files/buffers will be stored +in C<$output> as a concatenated series of compressed data streams. + + + + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<gzip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<gzip> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<gzip> has +completed. + +This parameter defaults to 0. + + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + + + + + +=item C<< Append => 0|1 >> + +TODO + + + +=back + + + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.gz>. + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + + my $input = "file1.txt"; + gzip $input => "$input.gz" + or die "gzip failed: $GzipError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + gzip $input => \$buffer + or die "gzip failed: $GzipError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + + gzip '</my/home/*.txt>' => '<*.gz>' + or die "gzip failed: $GzipError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.gz" ; + gzip $input => $output + or die "Error compressing '$input': $GzipError\n"; + } + + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::Gzip> is shown below + + my $z = new IO::Compress::Gzip $output [,OPTS] + or die "IO::Compress::Gzip failed: $GzipError\n"; + +It returns an C<IO::Compress::Gzip> object on success and undef on failure. +The variable C<$GzipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Gzip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::Gzip>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C<close> method is called or the C<IO::Compress::Gzip> +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data +will be append to the end if C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C<seek> before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + + + + + +=item C<< Merge => 0|1 >> + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + + + +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1952 data stream. + + + +There are a number of other limitations with the C<Merge> option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A +fatal error will be thrown if C<Merge> is used with an older version of +zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + + +This parameter defaults to 0. + + + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::Gzip> by default. + + use IO::Compress::Gzip qw(:strategy); + use IO::Compress::Gzip qw(:constants); + use IO::Compress::Gzip qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + + + + + + +=item C<< Minimal => 0|1 >> + +If specified, this option will force the creation of the smallest possible +compliant gzip header (which is exactly 10 bytes long) as defined in +RFC 1952. + +See the section titled "Compliance" in RFC 1952 for a definition +of the values used for the fields in the gzip header. + +All other parameters that control the content of the gzip header will +be ignored if this parameter is set to 1. + +This parameter defaults to 0. + +=item C<< Comment => $comment >> + +Stores the contents of C<$comment> in the COMMENT field in +the gzip header. +By default, no comment field is written to the gzip file. + +If the C<-Strict> option is enabled, the comment can only consist of ISO +8859-1 characters plus line feed. + +If the C<-Strict> option is disabled, the comment field can contain any +character except NULL. If any null characters are present, the field +will be truncated at the first NULL. + +=item C<< Name => $string >> + +Stores the contents of C<$string> in the gzip NAME header field. If +C<Name> is not specified, no gzip NAME field will be created. + +If the C<-Strict> option is enabled, C<$string> can only consist of ISO +8859-1 characters. + +If C<-Strict> is disabled, then C<$string> can contain any character +except NULL. If any null characters are present, the field will be +truncated at the first NULL. + +=item C<< Time => $number >> + +Sets the MTIME field in the gzip header to $number. + +This field defaults to the time the C<IO::Compress::Gzip> object was created +if this option is not specified. + +=item C<< TextFlag => 0|1 >> + +This parameter controls the setting of the FLG.FTEXT bit in the gzip +header. It is used to signal that the data stored in the gzip file/buffer +is probably text. + +The default is 0. + +=item C<< HeaderCRC => 0|1 >> + +When true this parameter will set the FLG.FHCRC bit to 1 in the gzip header +and set the CRC16 header field to the CRC of the complete gzip header +except the CRC16 field itself. + +B<Note> that gzip files created with the C<HeaderCRC> flag set to 1 cannot +be read by most, if not all, of the the standard gunzip utilities, most +notably gzip version 1.2.4. You should therefore avoid using this option if +you want to maximize the portability of your gzip files. + +This parameter defaults to 0. + +=item C<< OS_Code => $value >> + +Stores C<$value> in the gzip OS header field. A number between 0 and 255 is +valid. + +If not specified, this parameter defaults to the OS code of the Operating +System this module was built on. The value 3 is used as a catch-all for all +Unix variants and unknown Operating Systems. + +=item C<< ExtraField => $data >> + +This parameter allows additional metadata to be stored in the ExtraField in +the gzip header. An RFC 1952 compliant ExtraField consists of zero or more +subfields. Each subfield consists of a two byte header followed by the +subfield data. + +The list of subfields can be supplied in any of the following formats + + -ExtraField => [$id1, $data1, + $id2, $data2, + ... + ] + -ExtraField => [ [$id1 => $data1], + [$id2 => $data2], + ... + ] + -ExtraField => { $id1 => $data1, + $id2 => $data2, + ... + } + +Where C<$id1>, C<$id2> are two byte subfield ID's. The second byte of +the ID cannot be 0, unless the C<Strict> option has been disabled. + +If you use the hash syntax, you have no control over the order in which +the ExtraSubFields are stored, plus you cannot have SubFields with +duplicate ID. + +Alternatively the list of subfields can by supplied as a scalar, thus + + -ExtraField => $rawdata + +If you use the raw format, and the C<Strict> option is enabled, +C<IO::Compress::Gzip> will check that C<$rawdata> consists of zero or more +conformant sub-fields. When C<Strict> is disabled, C<$rawdata> can +consist of any arbitrary byte stream. + +The maximum size of the Extra Field 65535 bytes. + +=item C<< ExtraFlags => $value >> + +Sets the XFL byte in the gzip header to C<$value>. + +If this option is not present, the value stored in XFL field will be +determined by the setting of the C<Level> option. + +If C<< Level => Z_BEST_SPEED >> has been specified then XFL is set to 2. +If C<< Level => Z_BEST_COMPRESSION >> has been specified then XFL is set to 4. +Otherwise XFL is set to 0. + + + +=item C<< Strict => 0|1 >> + + + +C<Strict> will optionally police the values supplied with other options +to ensure they are compliant with RFC1952. + +This option is enabled by default. + +If C<Strict> is enabled the following behaviour will be policed: + +=over 5 + +=item * + +The value supplied with the C<Name> option can only contain ISO 8859-1 +characters. + +=item * + +The value supplied with the C<Comment> option can only contain ISO 8859-1 +characters plus line-feed. + +=item * + +The values supplied with the C<-Name> and C<-Comment> options cannot +contain multiple embedded nulls. + +=item * + +If an C<ExtraField> option is specified and it is a simple scalar, +it must conform to the sub-field structure as defined in RFC 1952. + +=item * + +If an C<ExtraField> option is specified the second byte of the ID will be +checked in each subfield to ensure that it does not contain the reserved +value 0x00. + +=back + +When C<Strict> is disabled the following behaviour will be policed: + +=over 5 + +=item * + +The value supplied with C<-Name> option can contain +any character except NULL. + +=item * + +The value supplied with C<-Comment> option can contain any character +except NULL. + +=item * + +The values supplied with the C<-Name> and C<-Comment> options can contain +multiple embedded nulls. The string written to the gzip header will +consist of the characters up to, but not including, the first embedded +NULL. + +=item * + +If an C<ExtraField> option is specified and it is a simple scalar, the +structure will not be checked. The only error is if the length is too big. + +=item * + +The ID header in an C<ExtraField> sub-field can consist of any two bytes. + +=back + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + + $z->flush; + $z->flush($flush_type); + + +Flushes any pending compressed data to the output file/buffer. + + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + + +Returns true on success. + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the C<close> method has been called. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + +This method always returns C<undef> when compressing. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Flushes any pending compressed data and then closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Gzip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::Gzip +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the the options that are available when creating +the C<$z> object. + +See the L</"Constructor Options"> section for more details. + + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + + +=head1 Importing + + +A number of symbolic constants are required by some methods in +C<IO::Compress::Gzip>. None are imported by default. + + + +=over 5 + +=item :all + + +Imports C<gzip>, C<$GzipError> and all symbolic +constants that can be used by C<IO::Compress::Gzip>. Same as doing this + + use IO::Compress::Gzip qw(gzip $GzipError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + + use IO::Compress::Gzip qw(:flush :level :strategy) ; + + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + + + + +=back + +For + +=head1 EXAMPLES + +TODO + + + + + + + + + + + +=head1 SEE ALSO + +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::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + + + + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/Gzip/Constants.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/Gzip/Constants.pm new file mode 100644 index 0000000000..3ccb04210c --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/Gzip/Constants.pm @@ -0,0 +1,137 @@ +package IO::Compress::Gzip::Constants; + +use strict ; +use warnings; +use bytes; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); +our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE); + +$VERSION = '2.004'; + +@ISA = qw(Exporter); + +@EXPORT= qw( + + GZIP_ID_SIZE + GZIP_ID1 + GZIP_ID2 + + GZIP_FLG_DEFAULT + GZIP_FLG_FTEXT + GZIP_FLG_FHCRC + GZIP_FLG_FEXTRA + GZIP_FLG_FNAME + GZIP_FLG_FCOMMENT + GZIP_FLG_RESERVED + + GZIP_CM_DEFLATED + + GZIP_MIN_HEADER_SIZE + GZIP_TRAILER_SIZE + + GZIP_MTIME_DEFAULT + GZIP_XFL_DEFAULT + GZIP_FEXTRA_HEADER_SIZE + GZIP_FEXTRA_MAX_SIZE + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE + GZIP_FEXTRA_SUBFIELD_ID_SIZE + GZIP_FEXTRA_SUBFIELD_LEN_SIZE + GZIP_FEXTRA_SUBFIELD_MAX_SIZE + + $GZIP_FNAME_INVALID_CHAR_RE + $GZIP_FCOMMENT_INVALID_CHAR_RE + + GZIP_FHCRC_SIZE + + GZIP_ISIZE_MAX + GZIP_ISIZE_MOD_VALUE + + + GZIP_NULL_BYTE + + GZIP_OS_DEFAULT + + %GZIP_OS_Names + + GZIP_MINIMUM_HEADER + + ); + +# Constant names derived from RFC 1952 + +use constant GZIP_ID_SIZE => 2 ; +use constant GZIP_ID1 => 0x1F; +use constant GZIP_ID2 => 0x8B; + +use constant GZIP_MIN_HEADER_SIZE => 10 ;# minimum gzip header size +use constant GZIP_TRAILER_SIZE => 8 ; + + +use constant GZIP_FLG_DEFAULT => 0x00 ; +use constant GZIP_FLG_FTEXT => 0x01 ; +use constant GZIP_FLG_FHCRC => 0x02 ; # called CONTINUATION in gzip +use constant GZIP_FLG_FEXTRA => 0x04 ; +use constant GZIP_FLG_FNAME => 0x08 ; +use constant GZIP_FLG_FCOMMENT => 0x10 ; +#use constant GZIP_FLG_ENCRYPTED => 0x20 ; # documented in gzip sources +use constant GZIP_FLG_RESERVED => (0x20 | 0x40 | 0x80) ; + +use constant GZIP_XFL_DEFAULT => 0x00 ; + +use constant GZIP_MTIME_DEFAULT => 0x00 ; + +use constant GZIP_FEXTRA_HEADER_SIZE => 2 ; +use constant GZIP_FEXTRA_MAX_SIZE => 0xFF ; +use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ; +use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ; +use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => GZIP_FEXTRA_SUBFIELD_ID_SIZE + + GZIP_FEXTRA_SUBFIELD_LEN_SIZE; +use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => GZIP_FEXTRA_MAX_SIZE - + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE ; + + $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x1F\x7F-\x9F]'; + $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x09\x11-\x1F\x7F-\x9F]'; + +use constant GZIP_FHCRC_SIZE => 2 ; # aka CONTINUATION in gzip + +use constant GZIP_CM_DEFLATED => 8 ; + +use constant GZIP_NULL_BYTE => "\x00"; +use constant GZIP_ISIZE_MAX => 0xFFFFFFFF ; +use constant GZIP_ISIZE_MOD_VALUE => GZIP_ISIZE_MAX + 1 ; + +# OS Names sourced from http://www.gzip.org/format.txt + +use constant GZIP_OS_DEFAULT=> 0xFF ; +%GZIP_OS_Names = ( + 0 => 'MS-DOS', + 1 => 'Amiga', + 2 => 'VMS', + 3 => 'Unix', + 4 => 'VM/CMS', + 5 => 'Atari TOS', + 6 => 'HPFS (OS/2, NT)', + 7 => 'Macintosh', + 8 => 'Z-System', + 9 => 'CP/M', + 10 => 'TOPS-20', + 11 => 'NTFS (NT)', + 12 => 'SMS QDOS', + 13 => 'Acorn RISCOS', + 14 => 'VFAT file system (Win95, NT)', + 15 => 'MVS', + 16 => 'BeOS', + 17 => 'Tandem/NSK', + 18 => 'THEOS', + GZIP_OS_DEFAULT() => 'Unknown', + ) ; + +use constant GZIP_MINIMUM_HEADER => pack("C4 V C C", + GZIP_ID1, GZIP_ID2, GZIP_CM_DEFLATED, GZIP_FLG_DEFAULT, + GZIP_MTIME_DEFAULT, GZIP_XFL_DEFAULT, GZIP_OS_DEFAULT) ; + + +1; diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/RawDeflate.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/RawDeflate.pm new file mode 100644 index 0000000000..11a2ae37df --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/RawDeflate.pm @@ -0,0 +1,1086 @@ +package IO::Compress::RawDeflate ; + +# create RFC1951 +# +use strict ; +use warnings; +use bytes; + + +use IO::Compress::Base 2.004 ; +use IO::Compress::Base::Common 2.004 qw(:Status createSelfTiedObject); +use IO::Compress::Adapter::Deflate 2.004 ; + +require Exporter ; + + +our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError); + +$VERSION = '2.004'; +$RawDeflateError = ''; + +@ISA = qw(Exporter IO::Compress::Base); +@EXPORT_OK = qw( $RawDeflateError rawdeflate ) ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; + +%EXPORT_TAGS = ( flush => [qw{ + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + }], + level => [qw{ + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + }], + strategy => [qw{ + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + }], + + ); + +{ + my %seen; + foreach (keys %EXPORT_TAGS ) + { + push @{$EXPORT_TAGS{constants}}, + grep { !$seen{$_}++ } + @{ $EXPORT_TAGS{$_} } + } + $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ; +} + +%DEFLATE_CONSTANTS = %EXPORT_TAGS; + +Exporter::export_ok_tags('all'); + + + +sub new +{ + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$RawDeflateError); + + return $obj->_create(undef, @_); +} + +sub rawdeflate +{ + my $obj = createSelfTiedObject(undef, \$RawDeflateError); + return $obj->_def(@_); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift; + + return 1 ; +} + +sub mkComp +{ + my $self = shift ; + my $class = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject( + $got->value('CRC32'), + $got->value('Adler32'), + $got->value('Level'), + $got->value('Strategy') + ); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + return $obj; +} + + +sub mkHeader +{ + my $self = shift ; + return ''; +} + +sub mkTrailer +{ + my $self = shift ; + return ''; +} + +sub mkFinalTrailer +{ + return ''; +} + + +#sub newHeader +#{ +# my $self = shift ; +# return ''; +#} + +sub getExtraParams +{ + my $self = shift ; + return $self->getZlibParams(); +} + +sub getZlibParams +{ + my $self = shift ; + + use IO::Compress::Base::Common 2.004 qw(:Parse); + use Compress::Raw::Zlib 2.004 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); + + + return ( + + # zlib behaviour + #'Method' => [0, 1, Parse_unsigned, Z_DEFLATED], + 'Level' => [0, 1, Parse_signed, Z_DEFAULT_COMPRESSION], + 'Strategy' => [0, 1, Parse_signed, Z_DEFAULT_STRATEGY], + + 'CRC32' => [0, 1, Parse_boolean, 0], + 'ADLER32' => [0, 1, Parse_boolean, 0], + 'Merge' => [1, 1, Parse_boolean, 0], + ); + + +} + +sub getInverseClass +{ + return ('IO::Uncompress::RawInflate', + \$IO::Uncompress::RawInflate::RawInflateError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $file = shift ; + +} + +use IO::Seekable qw(SEEK_SET); + +sub createMerge +{ + my $self = shift ; + my $outValue = shift ; + my $outType = shift ; + + my ($invClass, $error_ref) = $self->getInverseClass(); + eval "require $invClass" + or die "aaaahhhh" ; + + my $inf = $invClass->new( $outValue, + Transparent => 0, + #Strict => 1, + AutoClose => 0, + Scan => 1) + or return $self->saveErrorString(undef, "Cannot create InflateScan object: $$error_ref" ) ; + + my $end_offset = 0; + $inf->scan() + or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $inf->errorNo) ; + $inf->zap($end_offset) + or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $inf->errorNo) ; + + my $def = *$self->{Compress} = $inf->createDeflate(); + + *$self->{Header} = *$inf->{Info}{Header}; + *$self->{UnCompSize} = *$inf->{UnCompSize}->clone(); + *$self->{CompSize} = *$inf->{CompSize}->clone(); + # TODO -- fix this + #*$self->{CompSize} = new U64(0, *$self->{UnCompSize_32bit}); + + + if ( $outType eq 'buffer') + { substr( ${ *$self->{Buffer} }, $end_offset) = '' } + elsif ($outType eq 'handle' || $outType eq 'filename') { + *$self->{FH} = *$inf->{FH} ; + delete *$inf->{FH}; + *$self->{FH}->flush() ; + *$self->{Handle} = 1 if $outType eq 'handle'; + + #seek(*$self->{FH}, $end_offset, SEEK_SET) + *$self->{FH}->seek($end_offset, SEEK_SET) + or return $self->saveErrorString(undef, $!, $!) ; + } + + return $def ; +} + +#### zlib specific methods + +sub deflateParams +{ + my $self = shift ; + + my $level = shift ; + my $strategy = shift ; + + my $status = *$self->{Compress}->deflateParams(Level => $level, Strategy => $strategy) ; + return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) + if $status == STATUS_ERROR; + + return 1; +} + + + + +1; + +__END__ + +=head1 NAME + + + +IO::Compress::RawDeflate - Write RFC 1951 files/buffers + + + +=head1 SYNOPSIS + + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + + my $status = rawdeflate $input => $output [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + + my $z = new IO::Compress::RawDeflate $output [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $RawDeflateError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1951. + + + + + + + +Note that RFC 1951 data is not a good choice of compression format +to use in isolation, especially if you want to auto-detect it. + + + + + +For reading RFC 1951 files/buffers, see the companion module +L<IO::Uncompress::RawInflate|IO::Uncompress::RawInflate>. + + +=head1 Functional Interface + +A top-level function, C<rawdeflate>, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L</"OO Interface"> +section. + + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + rawdeflate $input => $output [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 rawdeflate $input => $output [, OPTS] + + +C<rawdeflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, each element in the array must be a +filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<rawdeflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<rawdeflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + + + +=head2 Notes + + + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the input files/buffers will be stored +in C<$output> as a concatenated series of compressed data streams. + + + + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<rawdeflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<rawdeflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<rawdeflate> has +completed. + +This parameter defaults to 0. + + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + + + + + +=item C<< Append => 0|1 >> + +TODO + + + +=back + + + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.1951>. + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + my $input = "file1.txt"; + rawdeflate $input => "$input.1951" + or die "rawdeflate failed: $RawDeflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + rawdeflate $input => \$buffer + or die "rawdeflate failed: $RawDeflateError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + rawdeflate '</my/home/*.txt>' => '<*.1951>' + or die "rawdeflate failed: $RawDeflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.1951" ; + rawdeflate $input => $output + or die "Error compressing '$input': $RawDeflateError\n"; + } + + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::RawDeflate> is shown below + + my $z = new IO::Compress::RawDeflate $output [,OPTS] + or die "IO::Compress::RawDeflate failed: $RawDeflateError\n"; + +It returns an C<IO::Compress::RawDeflate> object on success and undef on failure. +The variable C<$RawDeflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::RawDeflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::RawDeflate>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C<close> method is called or the C<IO::Compress::RawDeflate> +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data +will be append to the end if C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C<seek> before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + + + + + +=item C<< Merge => 0|1 >> + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + + + +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1951 data stream. + + + +There are a number of other limitations with the C<Merge> option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A +fatal error will be thrown if C<Merge> is used with an older version of +zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + + +This parameter defaults to 0. + + + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::RawDeflate> by default. + + use IO::Compress::RawDeflate qw(:strategy); + use IO::Compress::RawDeflate qw(:constants); + use IO::Compress::RawDeflate qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + + + + + + +=item C<< Strict => 0|1 >> + + + +This is a placeholder option. + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + + $z->flush; + $z->flush($flush_type); + + +Flushes any pending compressed data to the output file/buffer. + + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + + +Returns true on success. + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the C<close> method has been called. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + +This method always returns C<undef> when compressing. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Flushes any pending compressed data and then closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::RawDeflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::RawDeflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the the options that are available when creating +the C<$z> object. + +See the L</"Constructor Options"> section for more details. + + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + + +=head1 Importing + + +A number of symbolic constants are required by some methods in +C<IO::Compress::RawDeflate>. None are imported by default. + + + +=over 5 + +=item :all + + +Imports C<rawdeflate>, C<$RawDeflateError> and all symbolic +constants that can be used by C<IO::Compress::RawDeflate>. Same as doing this + + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + + use IO::Compress::RawDeflate qw(:flush :level :strategy) ; + + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + + + + +=back + +For + +=head1 EXAMPLES + +TODO + + + + + + + + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + + + + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/Zip.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/Zip.pm new file mode 100644 index 0000000000..143760e3d5 --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/Zip.pm @@ -0,0 +1,1584 @@ +package IO::Compress::Zip ; + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.004 qw(:Status createSelfTiedObject); +use IO::Compress::RawDeflate 2.004 ; +use IO::Compress::Adapter::Deflate 2.004 ; +use IO::Compress::Adapter::Identity 2.004 ; +use IO::Compress::Zlib::Extra 2.004 ; +use IO::Compress::Zip::Constants 2.004 ; + + +use Compress::Raw::Zlib 2.004 qw(crc32) ; +BEGIN +{ + eval { require IO::Compress::Adapter::Bzip2 ; + import IO::Compress::Adapter::Bzip2 2.004 ; + require IO::Compress::Bzip2 ; + import IO::Compress::Bzip2 2.004 ; + } ; +} + + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $ZipError); + +$VERSION = '2.004'; +$ZipError = ''; + +@ISA = qw(Exporter IO::Compress::RawDeflate); +@EXPORT_OK = qw( $ZipError zip ) ; +%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; + +$EXPORT_TAGS{zip_method} = [qw( ZIP_CM_STORE ZIP_CM_DEFLATE ZIP_CM_BZIP2 )]; +push @{ $EXPORT_TAGS{all} }, @{ $EXPORT_TAGS{zip_method} }; + +Exporter::export_ok_tags('all'); + +sub new +{ + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$ZipError); + $obj->_create(undef, @_); +} + +sub zip +{ + my $obj = createSelfTiedObject(undef, \$ZipError); + return $obj->_def(@_); +} + +sub mkComp +{ + my $self = shift ; + my $class = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) ; + + if (*$self->{ZipData}{Method} == ZIP_CM_STORE) { + ($obj, $errstr, $errno) = IO::Compress::Adapter::Identity::mkCompObject( + $got->value('Level'), + $got->value('Strategy') + ); + } + elsif (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { + ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject( + $got->value('CRC32'), + $got->value('Adler32'), + $got->value('Level'), + $got->value('Strategy') + ); + } + elsif (*$self->{ZipData}{Method} == ZIP_CM_BZIP2) { + ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject( + $got->value('BlockSize100K'), + $got->value('WorkFactor'), + $got->value('Verbosity') + ); + *$self->{ZipData}{CRC32} = crc32(undef); + } + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + if (! defined *$self->{ZipData}{StartOffset}) { + *$self->{ZipData}{StartOffset} = 0; + *$self->{ZipData}{Offset} = new U64 ; + } + + return $obj; +} + +sub reset +{ + my $self = shift ; + + *$self->{Compress}->reset(); + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(''); + + return STATUS_OK; +} + +sub filterUncompressed +{ + my $self = shift ; + + if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { + *$self->{ZipData}{CRC32} = *$self->{Compress}->crc32(); + } + else { + *$self->{ZipData}{CRC32} = crc32(${$_[0]}, *$self->{ZipData}{CRC32}); + + } +} + +sub mkHeader +{ + my $self = shift; + my $param = shift ; + + *$self->{ZipData}{StartOffset} = *$self->{ZipData}{Offset}->get32bit() ; + + my $filename = ''; + $filename = $param->value('Name') || ''; + + my $comment = ''; + $comment = $param->value('Comment') || ''; + + my $hdr = ''; + + my $time = _unixToDosTime($param->value('Time')); + + my $extra = ''; + my $ctlExtra = ''; + my $empty = 0; + my $osCode = $param->value('OS_Code') ; + my $extFileAttr = 0 ; + + if (*$self->{ZipData}{Zip64}) { + $empty = 0xFFFF; + + my $x = ''; + $x .= pack "V V", 0, 0 ; # uncompressedLength + $x .= pack "V V", 0, 0 ; # compressedLength + $x .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to local hdr + #$x .= pack "V ", 0 ; # disk no + + $x = IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x); + $extra .= $x; + $ctlExtra .= $x; + } + + if (! $param->value('Minimal')) { + if (defined $param->value('exTime')) + { + $extra .= mkExtendedTime($param->value('MTime'), + $param->value('ATime'), + $param->value('CTime')); + + $ctlExtra .= mkExtendedTime($param->value('MTime')); + } + + if ( $param->value('UID') && $osCode == ZIP_OS_CODE_UNIX) + { + $extra .= mkUnix2Extra( $param->value('UID'), $param->value('GID')); + $ctlExtra .= mkUnix2Extra(); + } + + # TODO - this code assumes Unix. + #$extFileAttr = 0666 << 16 + # if $osCode == ZIP_OS_CODE_UNIX ; + + $extFileAttr = $param->value('ExtAttr') + if defined $param->value('ExtAttr') ; + + $extra .= $param->value('ExtraFieldLocal') + if defined $param->value('ExtraFieldLocal'); + + $ctlExtra .= $param->value('ExtraFieldCentral') + if defined $param->value('ExtraFieldCentral'); + } + + my $gpFlag = 0 ; + $gpFlag |= ZIP_GP_FLAG_STREAMING_MASK + if *$self->{ZipData}{Stream} ; + + my $method = *$self->{ZipData}{Method} ; + + my $version = $ZIP_CM_MIN_VERSIONS{$method}; + $version = ZIP64_MIN_VERSION + if ZIP64_MIN_VERSION > $version && *$self->{ZipData}{Zip64}; + my $madeBy = ($param->value('OS_Code') << 8) + $version; + my $extract = $version; + + *$self->{ZipData}{Version} = $version; + *$self->{ZipData}{MadeBy} = $madeBy; + + my $ifa = 0; + $ifa |= ZIP_IFA_TEXT_MASK + if $param->value('TextFlag'); + + $hdr .= pack "V", ZIP_LOCAL_HDR_SIG ; # signature + $hdr .= pack 'v', $extract ; # extract Version & OS + $hdr .= pack 'v', $gpFlag ; # general purpose flag (set streaming mode) + $hdr .= pack 'v', $method ; # compression method (deflate) + $hdr .= pack 'V', $time ; # last mod date/time + $hdr .= pack 'V', 0 ; # crc32 - 0 when streaming + $hdr .= pack 'V', $empty ; # compressed length - 0 when streaming + $hdr .= pack 'V', $empty ; # uncompressed length - 0 when streaming + $hdr .= pack 'v', length $filename ; # filename length + $hdr .= pack 'v', length $extra ; # extra length + + $hdr .= $filename ; + $hdr .= $extra ; + + + my $ctl = ''; + + $ctl .= pack "V", ZIP_CENTRAL_HDR_SIG ; # signature + $ctl .= pack 'v', $madeBy ; # version made by + $ctl .= pack 'v', $extract ; # extract Version + $ctl .= pack 'v', $gpFlag ; # general purpose flag (streaming mode) + $ctl .= pack 'v', $method ; # compression method (deflate) + $ctl .= pack 'V', $time ; # last mod date/time + $ctl .= pack 'V', 0 ; # crc32 + $ctl .= pack 'V', $empty ; # compressed length + $ctl .= pack 'V', $empty ; # uncompressed length + $ctl .= pack 'v', length $filename ; # filename length + $ctl .= pack 'v', length $ctlExtra ; # extra length + $ctl .= pack 'v', length $comment ; # file comment length + $ctl .= pack 'v', 0 ; # disk number start + $ctl .= pack 'v', $ifa ; # internal file attributes + $ctl .= pack 'V', $extFileAttr ; # external file attributes + if (! *$self->{ZipData}{Zip64}) { + $ctl .= pack 'V', *$self->{ZipData}{Offset}->get32bit() ; # offset to local header + } + else { + $ctl .= pack 'V', $empty ; # offset to local header + } + + $ctl .= $filename ; + *$self->{ZipData}{StartOffset64} = 4 + length $ctl; + $ctl .= $ctlExtra ; + $ctl .= $comment ; + + *$self->{ZipData}{Offset}->add(length $hdr) ; + + *$self->{ZipData}{CentralHeader} = $ctl; + + return $hdr; +} + +sub mkTrailer +{ + my $self = shift ; + + my $crc32 ; + if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { + $crc32 = pack "V", *$self->{Compress}->crc32(); + } + else { + $crc32 = pack "V", *$self->{ZipData}{CRC32}; + } + + my $ctl = *$self->{ZipData}{CentralHeader} ; + + my $sizes ; + if (! *$self->{ZipData}{Zip64}) { + $sizes .= *$self->{CompSize}->getPacked_V32() ; # Compressed size + $sizes .= *$self->{UnCompSize}->getPacked_V32() ; # Uncompressed size + } + else { + $sizes .= *$self->{CompSize}->getPacked_V64() ; # Compressed size + $sizes .= *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size + } + + my $data = $crc32 . $sizes ; + + + my $hdr = ''; + + if (*$self->{ZipData}{Stream}) { + $hdr = pack "V", ZIP_DATA_HDR_SIG ; # signature + $hdr .= $data ; + } + else { + $self->writeAt(*$self->{ZipData}{StartOffset} + 14, $data) + or return undef; + } + + if (! *$self->{ZipData}{Zip64}) + { substr($ctl, 16, length $data) = $data } + else { + substr($ctl, 16, length $crc32) = $crc32 ; + my $s = *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size + $s .= *$self->{CompSize}->getPacked_V64() ; # Compressed size + substr($ctl, *$self->{ZipData}{StartOffset64}, length $s) = $s ; + } + + *$self->{ZipData}{Offset}->add(length($hdr)); + *$self->{ZipData}{Offset}->add( *$self->{CompSize} ); + push @{ *$self->{ZipData}{CentralDir} }, $ctl ; + + return $hdr; +} + +sub mkFinalTrailer +{ + my $self = shift ; + + my $comment = ''; + $comment = *$self->{ZipData}{ZipComment} ; + + my $cd_offset = *$self->{ZipData}{Offset}->get32bit() ; # offset to start central dir + + my $entries = @{ *$self->{ZipData}{CentralDir} }; + my $cd = join '', @{ *$self->{ZipData}{CentralDir} }; + my $cd_len = length $cd ; + + my $z64e = ''; + + if ( *$self->{ZipData}{Zip64} ) { + + my $v = *$self->{ZipData}{Version} ; + my $mb = *$self->{ZipData}{MadeBy} ; + $z64e .= pack 'v', $v ; # Version made by + $z64e .= pack 'v', $mb ; # Version to extract + $z64e .= pack 'V', 0 ; # number of disk + $z64e .= pack 'V', 0 ; # number of disk with central dir + $z64e .= U64::pack_V64 $entries ; # entries in central dir on this disk + $z64e .= U64::pack_V64 $entries ; # entries in central dir + $z64e .= U64::pack_V64 $cd_len ; # size of central dir + $z64e .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to start central dir + + $z64e = pack("V", ZIP64_END_CENTRAL_REC_HDR_SIG) # signature + . U64::pack_V64(length $z64e) + . $z64e ; + + *$self->{ZipData}{Offset}->add(length $cd) ; + + $z64e .= pack "V", ZIP64_END_CENTRAL_LOC_HDR_SIG; # signature + $z64e .= pack 'V', 0 ; # number of disk with central dir + $z64e .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to end zip64 central dir + $z64e .= pack 'V', 1 ; # Total number of disks + + # TODO - fix these when info-zip 3 is fixed. + #$cd_len = + #$cd_offset = + $entries = 0xFFFF ; + } + + my $ecd = ''; + $ecd .= pack "V", ZIP_END_CENTRAL_HDR_SIG ; # signature + $ecd .= pack 'v', 0 ; # number of disk + $ecd .= pack 'v', 0 ; # number of disk with central dir + $ecd .= pack 'v', $entries ; # entries in central dir on this disk + $ecd .= pack 'v', $entries ; # entries in central dir + $ecd .= pack 'V', $cd_len ; # size of central dir + $ecd .= pack 'V', $cd_offset ; # offset to start central dir + $ecd .= pack 'v', length $comment ; # zipfile comment length + $ecd .= $comment; + + return $cd . $z64e . $ecd ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift; + + $got->value('CRC32' => 1); + + if (! $got->parsed('Time') ) { + # Modification time defaults to now. + $got->value('Time' => time) ; + } + + if (! $got->parsed('exTime') ) { + my $timeRef = $got->value('exTime'); + if ( defined $timeRef) { + return $self->saveErrorString(undef, "exTime not a 3-element array ref") + if ref $timeRef ne 'ARRAY' || @$timeRef != 3; + } + + $got->value("MTime", $timeRef->[1]); + $got->value("ATime", $timeRef->[0]); + $got->value("CTime", $timeRef->[2]); + } + + *$self->{ZipData}{Zip64} = $got->value('Zip64'); + *$self->{ZipData}{Stream} = $got->value('Stream'); + + return $self->saveErrorString(undef, "Zip64 only supported if Stream enabled") + if *$self->{ZipData}{Zip64} && ! *$self->{ZipData}{Stream} ; + + my $method = $got->value('Method'); + return $self->saveErrorString(undef, "Unknown Method '$method'") + if ! defined $ZIP_CM_MIN_VERSIONS{$method}; + + return $self->saveErrorString(undef, "Bzip2 not available") + if $method == ZIP_CM_BZIP2 and + ! defined $IO::Compress::Adapter::Bzip2::VERSION; + + *$self->{ZipData}{Method} = $method; + + *$self->{ZipData}{ZipComment} = $got->value('ZipComment') ; + + for my $name (qw( ExtraFieldLocal ExtraFieldCentral )) + { + my $data = $got->value($name) ; + if (defined $data) { + my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, 1, 0) ; + return $self->saveErrorString(undef, "Error with $name Parameter: $bad") + if $bad ; + + $got->value($name, $data) ; + } + } + + return undef + if defined $IO::Compress::Bzip2::VERSION + and ! IO::Compress::Bzip2::ckParams($self, $got); + + return 1 ; +} + +#sub newHeader +#{ +# my $self = shift ; +# +# return $self->mkHeader(*$self->{Got}); +#} + +sub getExtraParams +{ + my $self = shift ; + + use IO::Compress::Base::Common 2.004 qw(:Parse); + use Compress::Raw::Zlib 2.004 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); + + my @Bzip2 = (); + + @Bzip2 = IO::Compress::Bzip2::getExtraParams($self) + if defined $IO::Compress::Bzip2::VERSION; + + return ( + # zlib behaviour + $self->getZlibParams(), + + 'Stream' => [1, 1, Parse_boolean, 1], + #'Store' => [0, 1, Parse_boolean, 0], + 'Method' => [0, 1, Parse_unsigned, ZIP_CM_DEFLATE], + +# # Zip header fields + 'Minimal' => [0, 1, Parse_boolean, 0], + 'Zip64' => [0, 1, Parse_boolean, 0], + 'Comment' => [0, 1, Parse_any, ''], + 'ZipComment'=> [0, 1, Parse_any, ''], + 'Name' => [0, 1, Parse_any, ''], + 'Time' => [0, 1, Parse_any, undef], + 'exTime' => [0, 1, Parse_any, undef], + 'ExtAttr' => [0, 1, Parse_any, 0], + 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code], + + 'TextFlag' => [0, 1, Parse_boolean, 0], + 'ExtraFieldLocal' => [0, 1, Parse_any, undef], + 'ExtraFieldCentral'=> [0, 1, Parse_any, undef], + + @Bzip2, + ); +} + +sub getInverseClass +{ + return ('IO::Uncompress::Unzip', + \$IO::Uncompress::Unzip::UnzipError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $filename = shift ; + + my ($mode, $uid, $gid, $atime, $mtime, $ctime) + = (stat($filename))[2, 4,5, 8,9,10] ; + + $params->value('Name' => $filename) + if ! $params->parsed('Name') ; + + $params->value('Time' => $mtime) + if ! $params->parsed('Time') ; + + if ( ! $params->parsed('exTime')) + { + $params->value('MTime' => $mtime) ; + $params->value('ATime' => $atime) ; + $params->value('CTime' => undef) ; # No Creation time + } + + $params->value('ExtAttr' => $mode << 16) + if ! $params->parsed('ExtAttr'); + + $params->value('UID' => $uid) ; + $params->value('GID' => $gid) ; + +} + +sub mkExtendedTime +{ + # order expected is m, a, c + + my $times = ''; + my $bit = 1 ; + my $flags = 0; + + for my $time (@_) + { + if (defined $time) + { + $flags |= $bit; + $times .= pack("V", $time); + } + + $bit <<= 1 ; + } + + return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_EXT_TIMESTAMP, + pack("C", $flags) . $times); +} + +sub mkUnix2Extra +{ + my $ids = ''; + for my $id (@_) + { + $ids .= pack("v", $id); + } + + return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_INFO_ZIP_UNIX2, + $ids); +} + + +# from Archive::Zip +sub _unixToDosTime # Archive::Zip::Member +{ + my $time_t = shift; + # TODO - add something to cope with unix time < 1980 + my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t); + my $dt = 0; + $dt += ( $sec >> 1 ); + $dt += ( $min << 5 ); + $dt += ( $hour << 11 ); + $dt += ( $mday << 16 ); + $dt += ( ( $mon + 1 ) << 21 ); + $dt += ( ( $year - 80 ) << 25 ); + return $dt; +} + +1; + +__END__ + +=head1 NAME + + + +IO::Compress::Zip - Write zip files/buffers + + + +=head1 SYNOPSIS + + use IO::Compress::Zip qw(zip $ZipError) ; + + + my $status = zip $input => $output [,OPTS] + or die "zip failed: $ZipError\n"; + + my $z = new IO::Compress::Zip $output [,OPTS] + or die "zip failed: $ZipError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $ZipError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + + +This module provides a Perl interface that allows writing zip +compressed data to files or buffer. + + + + + + + + + +The primary purpose of this module is to provide streaming write access to +zip files and buffers. It is not a general-purpose file archiver. If that +is what you want, check out C<Archive::Zip>. + +At present three compression methods are supported by IO::Compress::Zip, +namely Store (no compression at all), Deflate and Bzip2. + +Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must +be installed. + + + + +For reading zip files/buffers, see the companion module +L<IO::Uncompress::Unzip|IO::Uncompress::Unzip>. + + +=head1 Functional Interface + +A top-level function, C<zip>, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L</"OO Interface"> +section. + + use IO::Compress::Zip qw(zip $ZipError) ; + + zip $input => $output [,OPTS] + or die "zip failed: $ZipError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 zip $input => $output [, OPTS] + + +C<zip> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, each element in the array must be a +filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<zip> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + +In addition, if C<$input> is a simple filename, the default values for +the C<Name>, C<Time>, C<ExtAttr> and C<exTime> options will be sourced from that file. + +If you do not want to use these defaults they can be overridden by +explicitly setting the C<Name>, C<Time>, C<ExtAttr> and C<exTime> options or by setting the +C<Minimal> parameter. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<zip> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + + + +=head2 Notes + + + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the input files/buffers will each be stored +in C<$output> as a distinct entry. + + + + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<zip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<zip> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<zip> has +completed. + +This parameter defaults to 0. + + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + + + + + +=item C<< Append => 0|1 >> + +TODO + + + +=back + + + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.zip>. + + use strict ; + use warnings ; + use IO::Compress::Zip qw(zip $ZipError) ; + + my $input = "file1.txt"; + zip $input => "$input.zip" + or die "zip failed: $ZipError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Zip qw(zip $ZipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + zip $input => \$buffer + or die "zip failed: $ZipError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Zip qw(zip $ZipError) ; + + zip '</my/home/*.txt>' => '<*.zip>' + or die "zip failed: $ZipError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Zip qw(zip $ZipError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.zip" ; + zip $input => $output + or die "Error compressing '$input': $ZipError\n"; + } + + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::Zip> is shown below + + my $z = new IO::Compress::Zip $output [,OPTS] + or die "IO::Compress::Zip failed: $ZipError\n"; + +It returns an C<IO::Compress::Zip> object on success and undef on failure. +The variable C<$ZipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Zip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::Zip>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C<close> method is called or the C<IO::Compress::Zip> +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data +will be append to the end if C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C<seek> before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + + + +=item C<< Name => $string >> + +Stores the contents of C<$string> in the zip filename header field. If +C<Name> is not specified, no zip filename field will be created. + +=item C<< Time => $number >> + +Sets the last modified time field in the zip header to $number. + +This field defaults to the time the C<IO::Compress::Zip> object was created +if this option is not specified. + +=item C<< ExtAttr => $attr >> + +This option controls the "external file attributes" field in the central +header of the zip file. This is a 4 byte field. + +This option defaults to 0. + +=item C<< exTime => [$atime, $mtime, $ctime] >> + +This option expects an array reference with exactly three elements: +C<$atime>, C<mtime> and C<$ctime>. These correspond to the last access +time, last modification time and creation time respectively. + +It uses these values to set the extended timestamp field in the local zip +header to the three values, $atime, $mtime, $ctime and sets the extended +timestamp field in the central zip header to C<$mtime>. + +If any of the three values is C<undef> that time value will not be used. +So, for example, to set only the C<$mtime> you would use this + + exTime => [undef, $mtime, undef] + +If the C<Minimal> option is set to true, this option will be ignored. + +By default no extended time field is created. + +=item C<< Comment => $comment >> + +Stores the contents of C<$comment> in the Central File Header of +the zip file. + +By default, no comment field is written to the zip file. + +=item C<< ZipComment => $comment >> + +Stores the contents of C<$comment> in the End of Central Directory record +of the zip file. + +By default, no comment field is written to the zip file. + +=item C<< Method => $method >> + +Controls which compression method is used. At present three compression +methods are supported, namely Store (no compression at all), Deflate and +Bzip2. + +The symbols, ZIP_CM_STORE, ZIP_CM_DEFLATE and ZIP_CM_BZIP2 are used to +select the compression method. + +These constants are not imported by C<IO::Compress::Zip> by default. + + use IO::Compress::Zip qw(:zip_method); + use IO::Compress::Zip qw(:constants); + use IO::Compress::Zip qw(:all); + +Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must +be installed. A fatal error will be thrown if you attempt to create Bzip2 +content when C<IO::Compress::Bzip2> is not available. + +The default method is ZIP_CM_DEFLATE. + +=item C<< Stream => 0|1 >> + +This option controls whether the zip file/buffer output is created in +streaming mode. + +Note that when outputting to a file with streaming mode disabled (C<Stream> +is 0), the output file must be seekable. + +The default is 1. + +=item C<< Zip64 => 0|1 >> + +Create a Zip64 zip file/buffer. This option should only be used if you want +to store files larger than 4 Gig. + +If you intend to manipulate the Zip64 zip files created with this module +using an external zip/unzip make sure that it supports streaming Zip64. + +In particular, if you are using Info-Zip you need to have zip version 3.x +or better to update a Zip64 archive and unzip version 6.x to read a zip64 +archive. At the time of writing both are beta status. + +When the C<Zip64> option is enabled, the C<Stream> option I<must> be +enabled as well. + +The default is 0. + +=item C<< TextFlag => 0|1 >> + +This parameter controls the setting of a bit in the zip central header. It +is used to signal that the data stored in the zip file/buffer is probably +text. + +The default is 0. + +=item C<< ExtraFieldLocal => $data >> +=item C<< ExtraFieldCentral => $data >> + +These options allows additional metadata to be stored in the local and +central headers in the zip file/buffer. + +An extra field consists of zero or more subfields. Each subfield consists +of a two byte header followed by the subfield data. + +The list of subfields can be supplied in any of the following formats + + ExtraFieldLocal => [$id1, $data1, + $id2, $data2, + ... + ] + + ExtraFieldLocal => [ [$id1 => $data1], + [$id2 => $data2], + ... + ] + + ExtraFieldLocal => { $id1 => $data1, + $id2 => $data2, + ... + } + +Where C<$id1>, C<$id2> are two byte subfield ID's. + +If you use the hash syntax, you have no control over the order in which +the ExtraSubFields are stored, plus you cannot have SubFields with +duplicate ID. + +Alternatively the list of subfields can by supplied as a scalar, thus + + ExtraField => $rawdata + +The Extended Time field, set using the C<exTime> option, is an example of +an extended field. + + + +If the C<Minimal> option is set to true, this option will be ignored. + +The maximum size of an extra field 65535 bytes. + +=item C<< Minimal => 1|0 >> + +If specified, this option will disable the creation of all extended fields +in the zip local and central headers. So the C<exTime>, C<ExtraFieldLocal> +and C<ExtraFieldCentral> options will be ignored. + +This parameter defaults to 0. + +=item C<< BlockSize100K => number >> + +Specify the number of 100K blocks bzip2 uses during compression. + +Valid values are from 1 to 9, where 9 is best compression. + +This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored +otherwise. + +The default is 1. + +=item C<< WorkFactor => number >> + +Specifies how much effort bzip2 should take before resorting to a slower +fallback compression algorithm. + +Valid values range from 0 to 250, where 0 means use the default value 30. + +This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored +otherwise. + +The default is 0. + + + + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::Zip> by default. + + use IO::Compress::Zip qw(:strategy); + use IO::Compress::Zip qw(:constants); + use IO::Compress::Zip qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + + + + + + +=item C<< Strict => 0|1 >> + + + +This is a placeholder option. + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + + $z->flush; + $z->flush($flush_type); + + +Flushes any pending compressed data to the output file/buffer. + + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + + +Returns true on success. + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the C<close> method has been called. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + +This method always returns C<undef> when compressing. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Flushes any pending compressed data and then closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Zip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::Zip +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the the options that are available when creating +the C<$z> object. + +See the L</"Constructor Options"> section for more details. + + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + + +=head1 Importing + + +A number of symbolic constants are required by some methods in +C<IO::Compress::Zip>. None are imported by default. + + + +=over 5 + +=item :all + + +Imports C<zip>, C<$ZipError> and all symbolic +constants that can be used by C<IO::Compress::Zip>. Same as doing this + + use IO::Compress::Zip qw(zip $ZipError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + + use IO::Compress::Zip qw(:flush :level :strategy :zip_method) ; + + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + + +=item :zip_method + +These symbolic constants are used by the C<Method> option in the +constructor. + + ZIP_CM_STORE + ZIP_CM_DEFLATE + ZIP_CM_BZIP2 + + + + +=back + +For + +=head1 EXAMPLES + +TODO + + + + + + + + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + + + + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/Zip/Constants.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/Zip/Constants.pm new file mode 100644 index 0000000000..b0505d6c40 --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/Zip/Constants.pm @@ -0,0 +1,95 @@ +package IO::Compress::Zip::Constants; + +use strict ; +use warnings; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS); + +$VERSION = '2.004'; + +@ISA = qw(Exporter); + +@EXPORT= qw( + + ZIP_CM_STORE + ZIP_CM_DEFLATE + ZIP_CM_BZIP2 + ZIP_CM_LZMA + + ZIP_LOCAL_HDR_SIG + ZIP_DATA_HDR_SIG + ZIP_CENTRAL_HDR_SIG + ZIP_END_CENTRAL_HDR_SIG + ZIP64_END_CENTRAL_REC_HDR_SIG + ZIP64_END_CENTRAL_LOC_HDR_SIG + ZIP64_ARCHIVE_EXTRA_SIG + ZIP64_DIGITAL_SIGNATURE_SIG + + ZIP_GP_FLAG_ENCRYPTED_MASK + ZIP_GP_FLAG_STREAMING_MASK + ZIP_GP_FLAG_PATCHED_MASK + ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK + + ZIP_EXTRA_ID_ZIP64 + ZIP_EXTRA_ID_EXT_TIMESTAMP + ZIP_EXTRA_ID_INFO_ZIP_UNIX2 + + ZIP_OS_CODE_UNIX + ZIP_OS_CODE_DEFAULT + + ZIP_IFA_TEXT_MASK + + %ZIP_CM_MIN_VERSIONS + ZIP64_MIN_VERSION + + ); + +# Compression types supported +use constant ZIP_CM_STORE => 0 ; +use constant ZIP_CM_DEFLATE => 8 ; +use constant ZIP_CM_BZIP2 => 12 ; +use constant ZIP_CM_LZMA => 14 ; # Not Supported yet + +# General Purpose Flag +use constant ZIP_GP_FLAG_ENCRYPTED_MASK => 1 ; +use constant ZIP_GP_FLAG_STREAMING_MASK => 8 ; +use constant ZIP_GP_FLAG_PATCHED_MASK => 32 ; +use constant ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK => 64 ; + +# Internal File Attributes +use constant ZIP_IFA_TEXT_MASK => 1; + +# Signatures for each of the headers +use constant ZIP_LOCAL_HDR_SIG => 0x04034b50; +use constant ZIP_DATA_HDR_SIG => 0x08074b50; +use constant ZIP_CENTRAL_HDR_SIG => 0x02014b50; +use constant ZIP_END_CENTRAL_HDR_SIG => 0x06054b50; +use constant ZIP64_END_CENTRAL_REC_HDR_SIG => 0x06064b50; +use constant ZIP64_END_CENTRAL_LOC_HDR_SIG => 0x07064b50; +use constant ZIP64_ARCHIVE_EXTRA_SIG => 0x08064b50; +use constant ZIP64_DIGITAL_SIGNATURE_SIG => 0x05054b50; + +use constant ZIP_OS_CODE_UNIX => 3; +use constant ZIP_OS_CODE_DEFAULT => 3; + +# Extra Field ID's +use constant ZIP_EXTRA_ID_ZIP64 => pack "v", 1; +use constant ZIP_EXTRA_ID_EXT_TIMESTAMP => "UT"; +use constant ZIP_EXTRA_ID_INFO_ZIP_UNIX2 => "Ux"; + +use constant ZIP64_MIN_VERSION => 45; + +%ZIP_CM_MIN_VERSIONS = ( + ZIP_CM_STORE() => 20, + ZIP_CM_DEFLATE() => 20, + ZIP_CM_BZIP2() => 46, + ZIP_CM_LZMA() => 63, + ); + + +1; + +__END__ + diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/Zlib/Constants.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/Zlib/Constants.pm new file mode 100644 index 0000000000..492b2e3ddd --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/Zlib/Constants.pm @@ -0,0 +1,77 @@ + +package IO::Compress::Zlib::Constants ; + +use strict ; +use warnings; +use bytes; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT); + +$VERSION = '2.004'; + +@ISA = qw(Exporter); + +@EXPORT= qw( + + ZLIB_HEADER_SIZE + ZLIB_TRAILER_SIZE + + ZLIB_CMF_CM_OFFSET + ZLIB_CMF_CM_BITS + ZLIB_CMF_CM_DEFLATED + + ZLIB_CMF_CINFO_OFFSET + ZLIB_CMF_CINFO_BITS + ZLIB_CMF_CINFO_MAX + + ZLIB_FLG_FCHECK_OFFSET + ZLIB_FLG_FCHECK_BITS + + ZLIB_FLG_FDICT_OFFSET + ZLIB_FLG_FDICT_BITS + + ZLIB_FLG_LEVEL_OFFSET + ZLIB_FLG_LEVEL_BITS + + ZLIB_FLG_LEVEL_FASTEST + ZLIB_FLG_LEVEL_FAST + ZLIB_FLG_LEVEL_DEFAULT + ZLIB_FLG_LEVEL_SLOWEST + + ZLIB_FDICT_SIZE + + ); + +# Constant names derived from RFC1950 + +use constant ZLIB_HEADER_SIZE => 2; +use constant ZLIB_TRAILER_SIZE => 4; + +use constant ZLIB_CMF_CM_OFFSET => 0; +use constant ZLIB_CMF_CM_BITS => 0xF ; # 0b1111 +use constant ZLIB_CMF_CM_DEFLATED => 8; + +use constant ZLIB_CMF_CINFO_OFFSET => 4; +use constant ZLIB_CMF_CINFO_BITS => 0xF ; # 0b1111; +use constant ZLIB_CMF_CINFO_MAX => 7; + +use constant ZLIB_FLG_FCHECK_OFFSET => 0; +use constant ZLIB_FLG_FCHECK_BITS => 0x1F ; # 0b11111; + +use constant ZLIB_FLG_FDICT_OFFSET => 5; +use constant ZLIB_FLG_FDICT_BITS => 0x1 ; # 0b1; + +use constant ZLIB_FLG_LEVEL_OFFSET => 6; +use constant ZLIB_FLG_LEVEL_BITS => 0x3 ; # 0b11; + +use constant ZLIB_FLG_LEVEL_FASTEST => 0; +use constant ZLIB_FLG_LEVEL_FAST => 1; +use constant ZLIB_FLG_LEVEL_DEFAULT => 2; +use constant ZLIB_FLG_LEVEL_SLOWEST => 3; + +use constant ZLIB_FDICT_SIZE => 4; + + +1; diff --git a/ext/IO_Compress_Zlib/lib/IO/Compress/Zlib/Extra.pm b/ext/IO_Compress_Zlib/lib/IO/Compress/Zlib/Extra.pm new file mode 100644 index 0000000000..4034e3a481 --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Compress/Zlib/Extra.pm @@ -0,0 +1,198 @@ +package IO::Compress::Zlib::Extra; + +require 5.004 ; + +use strict ; +use warnings; +use bytes; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); + +$VERSION = '2.004'; + +use IO::Compress::Gzip::Constants 2.004 ; + +sub ExtraFieldError +{ + return $_[0]; + return "Error with ExtraField Parameter: $_[0]" ; +} + +sub validateExtraFieldPair +{ + my $pair = shift ; + my $strict = shift; + my $gzipMode = shift ; + + return ExtraFieldError("Not an array ref") + unless ref $pair && ref $pair eq 'ARRAY'; + + return ExtraFieldError("SubField must have two parts") + unless @$pair == 2 ; + + return ExtraFieldError("SubField ID is a reference") + if ref $pair->[0] ; + + return ExtraFieldError("SubField Data is a reference") + if ref $pair->[1] ; + + # ID is exactly two chars + return ExtraFieldError("SubField ID not two chars long") + unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ; + + # Check that the 2nd byte of the ID isn't 0 + return ExtraFieldError("SubField ID 2nd byte is 0x00") + if $strict && $gzipMode && substr($pair->[0], 1, 1) eq "\x00" ; + + return ExtraFieldError("SubField Data too long") + if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ; + + + return undef ; +} + +sub parseRawExtra +{ + my $data = shift ; + my $extraRef = shift; + my $strict = shift; + my $gzipMode = shift ; + + #my $lax = shift ; + + #return undef + # if $lax ; + + my $XLEN = length $data ; + + return ExtraFieldError("Too Large") + if $XLEN > GZIP_FEXTRA_MAX_SIZE; + + my $offset = 0 ; + while ($offset < $XLEN) { + + return ExtraFieldError("Truncated in FEXTRA Body Section") + if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; + + my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); + $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; + + my $subLen = unpack("v", substr($data, $offset, + GZIP_FEXTRA_SUBFIELD_LEN_SIZE)); + $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; + + return ExtraFieldError("Truncated in FEXTRA Body Section") + if $offset + $subLen > $XLEN ; + + my $bad = validateExtraFieldPair( [$id, + substr($data, $offset, $subLen)], + $strict, $gzipMode ); + return $bad if $bad ; + push @$extraRef, [$id => substr($data, $offset, $subLen)] + if defined $extraRef;; + + $offset += $subLen ; + } + + + return undef ; +} + + +sub mkSubField +{ + my $id = shift ; + my $data = shift ; + + return $id . pack("v", length $data) . $data ; +} + +sub parseExtraField +{ + my $dataRef = $_[0]; + my $strict = $_[1]; + my $gzipMode = $_[2]; + #my $lax = @_ == 2 ? $_[1] : 1; + + + # ExtraField can be any of + # + # -ExtraField => $data + # + # -ExtraField => [$id1, $data1, + # $id2, $data2] + # ... + # ] + # + # -ExtraField => [ [$id1 => $data1], + # [$id2 => $data2], + # ... + # ] + # + # -ExtraField => { $id1 => $data1, + # $id2 => $data2, + # ... + # } + + if ( ! ref $dataRef ) { + + return undef + if ! $strict; + + return parseRawExtra($dataRef, undef, 1, $gzipMode); + } + + #my $data = $$dataRef; + my $data = $dataRef; + my $out = '' ; + + if (ref $data eq 'ARRAY') { + if (ref $data->[0]) { + + foreach my $pair (@$data) { + return ExtraFieldError("Not list of lists") + unless ref $pair eq 'ARRAY' ; + + my $bad = validateExtraFieldPair($pair, $strict, $gzipMode) ; + return $bad if $bad ; + + $out .= mkSubField(@$pair); + } + } + else { + return ExtraFieldError("Not even number of elements") + unless @$data % 2 == 0; + + for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) { + my $bad = validateExtraFieldPair([$data->[$ix], + $data->[$ix+1]], + $strict, $gzipMode) ; + return $bad if $bad ; + + $out .= mkSubField($data->[$ix], $data->[$ix+1]); + } + } + } + elsif (ref $data eq 'HASH') { + while (my ($id, $info) = each %$data) { + my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode); + return $bad if $bad ; + + $out .= mkSubField($id, $info); + } + } + else { + return ExtraFieldError("Not a scalar, array ref or hash ref") ; + } + + return ExtraFieldError("Too Large") + if length $out > GZIP_FEXTRA_MAX_SIZE; + + $_[0] = $out ; + + return undef; +} + +1; + +__END__ diff --git a/ext/IO_Compress_Zlib/lib/IO/Uncompress/Adapter/Identity.pm b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Adapter/Identity.pm new file mode 100644 index 0000000000..36b9fbbce3 --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Adapter/Identity.pm @@ -0,0 +1,102 @@ +package IO::Uncompress::Adapter::Identity; + +use warnings; +use strict; +use bytes; + +use IO::Compress::Base::Common 2.004 qw(:Status); + +our ($VERSION); + +$VERSION = '2.004'; + +use Compress::Raw::Zlib 2.004 (); + +sub mkUncompObject +{ + my $crc32 = 1; #shift ; + my $adler32 = shift; + + bless { 'CompSize' => 0, + 'UnCompSize' => 0, + 'wantCRC32' => $crc32, + 'CRC32' => Compress::Raw::Zlib::crc32(''), + 'wantADLER32'=> $adler32, + 'ADLER32' => Compress::Raw::Zlib::adler32(''), + } ; +} + +sub uncompr +{ + my $self = shift; + my $eof = $_[2]; + + if (defined ${ $_[0] } && length ${ $_[0] }) { + $self->{CompSize} += length ${ $_[0] } ; + $self->{UnCompSize} = $self->{CompSize} ; + + $self->{CRC32} = Compress::Raw::Zlib::crc32($_[0], $self->{CRC32}) + if $self->{wantCRC32}; + + $self->{ADLER32} = Compress::Zlib::adler32($_[0], $self->{ADLER32}) + if $self->{wantADLER32}; + + ${ $_[1] } .= ${ $_[0] }; + ${ $_[0] } = ""; + } + + return STATUS_ENDSTREAM if $eof; + return STATUS_OK ; +} + +sub reset +{ + my $self = shift; + + $self->{CompSize} = 0; + $self->{UnCompSize} = 0; + $self->{CRC32} = Compress::Raw::Zlib::crc32(''); + $self->{ADLER32} = Compress::Raw::Zlib::adler32(''); + + return STATUS_OK ; +} + + +#sub count +#{ +# my $self = shift ; +# return $self->{UnCompSize} ; +#} + +sub compressedBytes +{ + my $self = shift ; + return $self->{UnCompSize} ; +} + +sub uncompressedBytes +{ + my $self = shift ; + return $self->{UnCompSize} ; +} + +sub sync +{ + return STATUS_OK ; +} + +sub crc32 +{ + my $self = shift ; + return $self->{CRC32}; +} + +sub adler32 +{ + my $self = shift ; + return $self->{ADLER32}; +} + +1; + +__END__ diff --git a/ext/IO_Compress_Zlib/lib/IO/Uncompress/Adapter/Inflate.pm b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Adapter/Inflate.pm new file mode 100644 index 0000000000..6131c14140 --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Adapter/Inflate.pm @@ -0,0 +1,161 @@ +package IO::Uncompress::Adapter::Inflate; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.004 qw(:Status); +use Compress::Raw::Zlib 2.004 qw(Z_OK Z_DATA_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); + +our ($VERSION); +$VERSION = '2.004'; + + + +sub mkUncompObject +{ + my $crc32 = shift || 1; + my $adler32 = shift || 1; + my $scan = shift || 0; + + my $inflate ; + my $status ; + + if ($scan) + { + ($inflate, $status) = new Compress::Raw::Zlib::InflateScan + CRC32 => $crc32, + ADLER32 => $adler32, + WindowBits => - MAX_WBITS ; + } + else + { + ($inflate, $status) = new Compress::Raw::Zlib::Inflate + AppendOutput => 1, + CRC32 => $crc32, + ADLER32 => $adler32, + WindowBits => - MAX_WBITS ; + } + + return (undef, "Could not create Inflation object: $status", $status) + if $status != Z_OK ; + + return bless {'Inf' => $inflate, + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + } ; + +} + +sub uncompr +{ + my $self = shift ; + my $from = shift ; + my $to = shift ; + my $eof = shift ; + + my $inf = $self->{Inf}; + + my $status = $inf->inflate($from, $to, $eof); + $self->{ErrorNo} = $status; + + if ($status != Z_STREAM_END && $eof) + { + $self->{Error} = "unexpected end of file"; + return STATUS_ERROR; + } + + if ($status != Z_OK && $status != Z_STREAM_END ) + { + $self->{Error} = "Inflation Error: $status"; + return STATUS_ERROR; + } + + + return STATUS_OK if $status == Z_OK ; + return STATUS_ENDSTREAM if $status == Z_STREAM_END ; + return STATUS_ERROR ; +} + +sub reset +{ + my $self = shift ; + $self->{Inf}->inflateReset(); + + return STATUS_OK ; +} + +#sub count +#{ +# my $self = shift ; +# $self->{Inf}->inflateCount(); +#} + +sub crc32 +{ + my $self = shift ; + $self->{Inf}->crc32(); +} + +sub compressedBytes +{ + my $self = shift ; + $self->{Inf}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Inf}->uncompressedBytes(); +} + +sub adler32 +{ + my $self = shift ; + $self->{Inf}->adler32(); +} + +sub sync +{ + my $self = shift ; + ( $self->{Inf}->inflateSync(@_) == Z_OK) + ? STATUS_OK + : STATUS_ERROR ; +} + + +sub getLastBlockOffset +{ + my $self = shift ; + $self->{Inf}->getLastBlockOffset(); +} + +sub getEndOffset +{ + my $self = shift ; + $self->{Inf}->getEndOffset(); +} + +sub resetLastBlockByte +{ + my $self = shift ; + $self->{Inf}->resetLastBlockByte(@_); +} + +sub createDeflateStream +{ + my $self = shift ; + my $deflate = $self->{Inf}->createDeflateStream(@_); + return bless {'Def' => $deflate, + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + }, 'IO::Compress::Adapter::Deflate'; +} + +1; + + +__END__ + diff --git a/ext/IO_Compress_Zlib/lib/IO/Uncompress/AnyInflate.pm b/ext/IO_Compress_Zlib/lib/IO/Uncompress/AnyInflate.pm new file mode 100644 index 0000000000..04c53ba7e6 --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Uncompress/AnyInflate.pm @@ -0,0 +1,1055 @@ +package IO::Uncompress::AnyInflate ; + +# for RFC1950, RFC1951 or RFC1952 + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.004 qw(createSelfTiedObject); + +use IO::Uncompress::Adapter::Inflate 2.004 (); + + +use IO::Uncompress::Base 2.004 ; +use IO::Uncompress::Gunzip 2.004 ; +use IO::Uncompress::Inflate 2.004 ; +use IO::Uncompress::RawInflate 2.004 ; +use IO::Uncompress::Unzip 2.004 ; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); + +$VERSION = '2.004'; +$AnyInflateError = ''; + +@ISA = qw( Exporter IO::Uncompress::Base ); +@EXPORT_OK = qw( $AnyInflateError anyinflate ) ; +%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +# TODO - allow the user to pick a set of the three formats to allow +# or just assume want to auto-detect any of the three formats. + +sub new +{ + my $class = shift ; + my $obj = createSelfTiedObject($class, \$AnyInflateError); + $obj->_create(undef, 0, @_); +} + +sub anyinflate +{ + my $obj = createSelfTiedObject(undef, \$AnyInflateError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + use IO::Compress::Base::Common 2.004 qw(:Parse); + return ( 'RawInflate' => [1, 1, Parse_boolean, 0] ) ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # any always needs both crc32 and adler32 + $got->value('CRC32' => 1); + $got->value('ADLER32' => 1); + + return 1; +} + +sub mkUncomp +{ + my $self = shift ; + my $class = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + my @possible = qw( Inflate Gunzip Unzip ); + unshift @possible, 'RawInflate' + if 1 || $got->value('RawInflate'); + + my $magic = $self->ckMagic( @possible ); + + if ($magic) { + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + return 1; + } + + return 0 ; +} + + + +sub ckMagic +{ + my $self = shift; + my @names = @_ ; + + my $keep = ref $self ; + for my $class ( map { "IO::Uncompress::$_" } @names) + { + bless $self => $class; + my $magic = $self->ckMagic(); + + if ($magic) + { + #bless $self => $class; + return $magic ; + } + + $self->pushBack(*$self->{HeaderPending}) ; + *$self->{HeaderPending} = '' ; + } + + bless $self => $keep; + return undef; +} + +1 ; + +__END__ + + +=head1 NAME + + +IO::Uncompress::AnyInflate - Uncompress zlib-based (zip, gzip) file/buffer + + +=head1 SYNOPSIS + + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + my $status = anyinflate $input => $output [,OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + + my $z = new IO::Uncompress::AnyInflate $input [OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $AnyInflateError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + +This module provides a Perl interface that allows the reading of +files/buffers that have been compressed in a number of formats that use the +zlib compression library. + +The formats supported are + +=over 5 + +=item RFC 1950 + +=item RFC 1951 (optionally) + +=item gzip (RFC 1952) + +=item zip + +=back + +The module will auto-detect which, if any, of the supported +compression formats is being used. + + + + + +=head1 Functional Interface + +A top-level function, C<anyinflate>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + anyinflate $input => $output [,OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 anyinflate $input => $output [, OPTS] + + +C<anyinflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, each element in the array must be a +filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<anyinflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the uncompressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<anyinflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + + + +=head2 Notes + + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + + + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<anyinflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<anyinflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<anyinflate> has +completed. + +This parameter defaults to 0. + + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + + + + + +=item C<< Append => 0|1 >> + +TODO + +=item C<< MultiStream => 0|1 >> + + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + + + + + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + + + +=back + + + + +=head2 Examples + +To read the contents of the file C<file1.txt.Compressed> and write the +compressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + my $input = "file1.txt.Compressed"; + my $output = "file1.txt"; + anyinflate $input => $output + or die "anyinflate failed: $AnyInflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.Compressed" + or die "Cannot open 'file1.txt.Compressed': $!\n" ; + my $buffer ; + anyinflate $input => \$buffer + or die "anyinflate failed: $AnyInflateError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.Compressed" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + anyinflate '</my/home/*.txt.Compressed>' => '</my/home/#1.txt>' + or die "anyinflate failed: $AnyInflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + for my $input ( glob "/my/home/*.txt.Compressed" ) + { + my $output = $input; + $output =~ s/.Compressed// ; + anyinflate $input => $output + or die "Error compressing '$input': $AnyInflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::AnyInflate is shown below + + + my $z = new IO::Uncompress::AnyInflate $input [OPTS] + or die "IO::Uncompress::AnyInflate failed: $AnyInflateError\n"; + +Returns an C<IO::Uncompress::AnyInflate> object on success and undef on failure. +The variable C<$AnyInflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::AnyInflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::AnyInflate object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + + + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/bufffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::AnyInflate will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + + + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + + +If the input is an RFC 1950 data stream, the following will be checked: + + + + +=over 5 + +=item 1 + +The ADLER32 checksum field must be present. + +=item 2 + +The value of the ADLER32 field read must match the adler32 value of the +uncompressed data actually contained in the file. + +=back + + + +If the input is a gzip (RFC 1952) data stream, the following will be checked: + + + + +=over 5 + +=item 1 + +If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the +header must match the crc16 value of the gzip header actually read. + +=item 2 + +If the gzip header contains a name field (FNAME) it consists solely of ISO +8859-1 characters. + +=item 3 + +If the gzip header contains a comment field (FCOMMENT) it consists solely +of ISO 8859-1 characters plus line-feed. + +=item 4 + +If the gzip FEXTRA header field is present it must conform to the sub-field +structure as defined in RFC 1952. + +=item 5 + +The CRC32 and ISIZE trailer fields must be present. + +=item 6 + +The value of the CRC32 field read must match the crc32 value of the +uncompressed data actually contained in the gzip file. + +=item 7 + +The value of the ISIZE fields read must match the length of the +uncompressed data actually read from the file. + +=back + + + + + +=item C<< RawInflate => 0|1 >> + +When auto-detecting the compressed format, try to test for raw-deflate (RFC +1951) content using the C<IO::Uncompress::RawInflate> module. + +The reason this is not default behaviour is because RFC 1951 content can +only be detected by attempting to uncompress it. This process is error +prone and can result is false positives. + +Defaults to 0. + + + + +=item C<< ParseExtra => 0|1 >> +If the gzip FEXTRA header field is present and this option is set, it will +force the module to check that it conforms to the sub-field structure as +defined in RFC 1952. + +If the C<Strict> is on it will automatically enable this option. + +Defaults to 0. + + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to to determine what constitutes a line +terminator. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::AnyInflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::AnyInflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::AnyInflate at present. + +=over 5 + +=item :all + +Imports C<anyinflate> and C<$AnyInflateError>. +Same as doing this + + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + + + + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/ext/IO_Compress_Zlib/lib/IO/Uncompress/Gunzip.pm b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Gunzip.pm new file mode 100644 index 0000000000..75dcf4ba42 --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Gunzip.pm @@ -0,0 +1,1181 @@ + +package IO::Uncompress::Gunzip ; + +require 5.004 ; + +# for RFC1952 + +use strict ; +use warnings; +use bytes; + +use IO::Uncompress::RawInflate 2.004 ; + +use Compress::Raw::Zlib 2.004 qw( crc32 ) ; +use IO::Compress::Base::Common 2.004 qw(:Status createSelfTiedObject); +use IO::Compress::Gzip::Constants 2.004 ; +use IO::Compress::Zlib::Extra 2.004 ; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GunzipError); + +@ISA = qw( Exporter IO::Uncompress::RawInflate ); +@EXPORT_OK = qw( $GunzipError gunzip ); +%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +$GunzipError = ''; + +$VERSION = '2.004'; + +sub new +{ + my $class = shift ; + $GunzipError = ''; + my $obj = createSelfTiedObject($class, \$GunzipError); + + $obj->_create(undef, 0, @_); +} + +sub gunzip +{ + my $obj = createSelfTiedObject(undef, \$GunzipError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + use IO::Compress::Base::Common 2.004 qw(:Parse); + return ( 'ParseExtra' => [1, 1, Parse_boolean, 0] ) ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gunzip always needs crc32 + $got->value('CRC32' => 1); + + return 1; +} + +sub ckMagic +{ + my $self = shift; + + my $magic ; + $self->smartReadExact(\$magic, GZIP_ID_SIZE); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") + if length $magic != GZIP_ID_SIZE ; + + return $self->HeaderError("Bad Magic") + if ! isGzipMagic($magic) ; + + *$self->{Type} = 'rfc1952'; + + return $magic ; +} + +sub readHeader +{ + my $self = shift; + my $magic = shift; + + return $self->_readGzipHeader($magic); +} + +sub chkTrailer +{ + my $self = shift; + my $trailer = shift; + + # Check CRC & ISIZE + my ($CRC32, $ISIZE) = unpack("V V", $trailer) ; + *$self->{Info}{CRC32} = $CRC32; + *$self->{Info}{ISIZE} = $ISIZE; + + if (*$self->{Strict}) { + return $self->TrailerError("CRC mismatch") + if $CRC32 != *$self->{Uncomp}->crc32() ; + + my $exp_isize = *$self->{UnCompSize}->get32bit(); + return $self->TrailerError("ISIZE mismatch. Got $ISIZE" + . ", expected $exp_isize") + if $ISIZE != $exp_isize ; + } + + return STATUS_OK; +} + +sub isGzipMagic +{ + my $buffer = shift ; + return 0 if length $buffer < GZIP_ID_SIZE ; + my ($id1, $id2) = unpack("C C", $buffer) ; + return $id1 == GZIP_ID1 && $id2 == GZIP_ID2 ; +} + +sub _readFullGzipHeader($) +{ + my ($self) = @_ ; + my $magic = '' ; + + $self->smartReadExact(\$magic, GZIP_ID_SIZE); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") + if length $magic != GZIP_ID_SIZE ; + + + return $self->HeaderError("Bad Magic") + if ! isGzipMagic($magic) ; + + my $status = $self->_readGzipHeader($magic); + delete *$self->{Transparent} if ! defined $status ; + return $status ; +} + +sub _readGzipHeader($) +{ + my ($self, $magic) = @_ ; + my ($HeaderCRC) ; + my ($buffer) = '' ; + + $self->smartReadExact(\$buffer, GZIP_MIN_HEADER_SIZE - GZIP_ID_SIZE) + or return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + # now split out the various parts + my ($cm, $flag, $mtime, $xfl, $os) = unpack("C C V C C", $buffer) ; + + $cm == GZIP_CM_DEFLATED + or return $self->HeaderError("Not Deflate (CM is $cm)") ; + + # check for use of reserved bits + return $self->HeaderError("Use of Reserved Bits in FLG field.") + if $flag & GZIP_FLG_RESERVED ; + + my $EXTRA ; + my @EXTRA = () ; + if ($flag & GZIP_FLG_FEXTRA) { + $EXTRA = "" ; + $self->smartReadExact(\$buffer, GZIP_FEXTRA_HEADER_SIZE) + or return $self->TruncatedHeader("FEXTRA Length") ; + + my ($XLEN) = unpack("v", $buffer) ; + $self->smartReadExact(\$EXTRA, $XLEN) + or return $self->TruncatedHeader("FEXTRA Body"); + $keep .= $buffer . $EXTRA ; + + if ($XLEN && *$self->{'ParseExtra'}) { + my $bad = IO::Compress::Zlib::Extra::parseRawExtra($EXTRA, + \@EXTRA, 1, 1); + return $self->HeaderError($bad) + if defined $bad; + } + } + + my $origname ; + if ($flag & GZIP_FLG_FNAME) { + $origname = "" ; + while (1) { + $self->smartReadExact(\$buffer, 1) + or return $self->TruncatedHeader("FNAME"); + last if $buffer eq GZIP_NULL_BYTE ; + $origname .= $buffer + } + $keep .= $origname . GZIP_NULL_BYTE ; + + return $self->HeaderError("Non ISO 8859-1 Character found in Name") + if *$self->{Strict} && $origname =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; + } + + my $comment ; + if ($flag & GZIP_FLG_FCOMMENT) { + $comment = ""; + while (1) { + $self->smartReadExact(\$buffer, 1) + or return $self->TruncatedHeader("FCOMMENT"); + last if $buffer eq GZIP_NULL_BYTE ; + $comment .= $buffer + } + $keep .= $comment . GZIP_NULL_BYTE ; + + return $self->HeaderError("Non ISO 8859-1 Character found in Comment") + if *$self->{Strict} && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o ; + } + + if ($flag & GZIP_FLG_FHCRC) { + $self->smartReadExact(\$buffer, GZIP_FHCRC_SIZE) + or return $self->TruncatedHeader("FHCRC"); + + $HeaderCRC = unpack("v", $buffer) ; + my $crc16 = crc32($keep) & 0xFF ; + + return $self->HeaderError("CRC16 mismatch.") + if *$self->{Strict} && $crc16 != $HeaderCRC; + + $keep .= $buffer ; + } + + # Assume compression method is deflated for xfl tests + #if ($xfl) { + #} + + *$self->{Type} = 'rfc1952'; + + return { + 'Type' => 'rfc1952', + 'FingerprintLength' => 2, + 'HeaderLength' => length $keep, + 'TrailerLength' => GZIP_TRAILER_SIZE, + 'Header' => $keep, + 'isMinimalHeader' => $keep eq GZIP_MINIMUM_HEADER ? 1 : 0, + + 'MethodID' => $cm, + 'MethodName' => $cm == GZIP_CM_DEFLATED ? "Deflated" : "Unknown" , + 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0, + 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0, + 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0, + 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0, + 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0, + 'Name' => $origname, + 'Comment' => $comment, + 'Time' => $mtime, + 'OsID' => $os, + 'OsName' => defined $GZIP_OS_Names{$os} + ? $GZIP_OS_Names{$os} : "Unknown", + 'HeaderCRC' => $HeaderCRC, + 'Flags' => $flag, + 'ExtraFlags' => $xfl, + 'ExtraFieldRaw' => $EXTRA, + 'ExtraField' => [ @EXTRA ], + + + #'CompSize'=> $compsize, + #'CRC32'=> $CRC32, + #'OrigSize'=> $ISIZE, + } +} + + +1; + +__END__ + + +=head1 NAME + + + +IO::Uncompress::Gunzip - Read RFC 1952 files/buffers + + + +=head1 SYNOPSIS + + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + my $status = gunzip $input => $output [,OPTS] + or die "gunzip failed: $GunzipError\n"; + + my $z = new IO::Uncompress::Gunzip $input [OPTS] + or die "gunzip failed: $GunzipError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $GunzipError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + + +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC 1952. + +For writing RFC 1952 files/buffers, see the companion module IO::Compress::Gzip. + + + + + +=head1 Functional Interface + +A top-level function, C<gunzip>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + gunzip $input => $output [,OPTS] + or die "gunzip failed: $GunzipError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 gunzip $input => $output [, OPTS] + + +C<gunzip> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, each element in the array must be a +filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<gunzip> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the uncompressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<gunzip> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + + + +=head2 Notes + + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + + + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<gunzip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<gunzip> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<gunzip> has +completed. + +This parameter defaults to 0. + + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + + + + + +=item C<< Append => 0|1 >> + +TODO + +=item C<< MultiStream => 0|1 >> + + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + + + + + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + + + +=back + + + + +=head2 Examples + +To read the contents of the file C<file1.txt.gz> and write the +compressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + my $input = "file1.txt.gz"; + my $output = "file1.txt"; + gunzip $input => $output + or die "gunzip failed: $GunzipError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.gz" + or die "Cannot open 'file1.txt.gz': $!\n" ; + my $buffer ; + gunzip $input => \$buffer + or die "gunzip failed: $GunzipError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.gz" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + gunzip '</my/home/*.txt.gz>' => '</my/home/#1.txt>' + or die "gunzip failed: $GunzipError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + for my $input ( glob "/my/home/*.txt.gz" ) + { + my $output = $input; + $output =~ s/.gz// ; + gunzip $input => $output + or die "Error compressing '$input': $GunzipError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::Gunzip is shown below + + + my $z = new IO::Uncompress::Gunzip $input [OPTS] + or die "IO::Uncompress::Gunzip failed: $GunzipError\n"; + +Returns an C<IO::Uncompress::Gunzip> object on success and undef on failure. +The variable C<$GunzipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::Gunzip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::Gunzip object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + + + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/bufffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::Gunzip will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + + + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + + + + + + + + + +=over 5 + +=item 1 + +If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the +header must match the crc16 value of the gzip header actually read. + +=item 2 + +If the gzip header contains a name field (FNAME) it consists solely of ISO +8859-1 characters. + +=item 3 + +If the gzip header contains a comment field (FCOMMENT) it consists solely +of ISO 8859-1 characters plus line-feed. + +=item 4 + +If the gzip FEXTRA header field is present it must conform to the sub-field +structure as defined in RFC 1952. + +=item 5 + +The CRC32 and ISIZE trailer fields must be present. + +=item 6 + +The value of the CRC32 field read must match the crc32 value of the +uncompressed data actually contained in the gzip file. + +=item 7 + +The value of the ISIZE fields read must match the length of the +uncompressed data actually read from the file. + +=back + + + + + + + +=item C<< ParseExtra => 0|1 >> +If the gzip FEXTRA header field is present and this option is set, it will +force the module to check that it conforms to the sub-field structure as +defined in RFC 1952. + +If the C<Strict> is on it will automatically enable this option. + +Defaults to 0. + + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + + + +=over 5 + +=item Name + +The contents of the Name header field, if present. If no name is +present, the value will be undef. Note this is different from a zero length +name, which will return an empty string. + +=item Comment + +The contents of the Comment header field, if present. If no comment is +present, the value will be undef. Note this is different from a zero length +comment, which will return an empty string. + +=back + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to to determine what constitutes a line +terminator. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::Gunzip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::Gunzip +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::Gunzip at present. + +=over 5 + +=item :all + +Imports C<gunzip> and C<$GunzipError>. +Same as doing this + + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + + + + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/ext/IO_Compress_Zlib/lib/IO/Uncompress/Inflate.pm b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Inflate.pm new file mode 100644 index 0000000000..c39170d44b --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Inflate.pm @@ -0,0 +1,1048 @@ +package IO::Uncompress::Inflate ; +# for RFC1950 + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.004 qw(:Status createSelfTiedObject); +use IO::Compress::Zlib::Constants 2.004 ; + +use IO::Uncompress::RawInflate 2.004 ; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); + +$VERSION = '2.004'; +$InflateError = ''; + +@ISA = qw( Exporter IO::Uncompress::RawInflate ); +@EXPORT_OK = qw( $InflateError inflate ) ; +%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + +sub new +{ + my $class = shift ; + my $obj = createSelfTiedObject($class, \$InflateError); + + $obj->_create(undef, 0, @_); +} + +sub inflate +{ + my $obj = createSelfTiedObject(undef, \$InflateError); + return $obj->_inf(@_); +} + +sub getExtraParams +{ + return (); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gunzip always needs adler32 + $got->value('ADLER32' => 1); + + return 1; +} + +sub ckMagic +{ + my $self = shift; + + my $magic ; + $self->smartReadExact(\$magic, ZLIB_HEADER_SIZE); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Header size is " . + ZLIB_HEADER_SIZE . " bytes") + if length $magic != ZLIB_HEADER_SIZE; + + #return $self->HeaderError("CRC mismatch.") + return undef + if ! $self->isZlibMagic($magic) ; + + *$self->{Type} = 'rfc1950'; + return $magic; +} + +sub readHeader +{ + my $self = shift; + my $magic = shift ; + + return $self->_readDeflateHeader($magic) ; +} + +sub chkTrailer +{ + my $self = shift; + my $trailer = shift; + + my $ADLER32 = unpack("N", $trailer) ; + *$self->{Info}{ADLER32} = $ADLER32; + return $self->TrailerError("CRC mismatch") + if *$self->{Strict} && $ADLER32 != *$self->{Uncomp}->adler32() ; + + return STATUS_OK; +} + + + +sub isZlibMagic +{ + my $self = shift; + my $buffer = shift ; + + return 0 + if length $buffer < ZLIB_HEADER_SIZE ; + + my $hdr = unpack("n", $buffer) ; + #return 0 if $hdr % 31 != 0 ; + return $self->HeaderError("CRC mismatch.") + if $hdr % 31 != 0 ; + + my ($CMF, $FLG) = unpack "C C", $buffer; + my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ; + + # Only Deflate supported + return $self->HeaderError("Not Deflate (CM is $cm)") + if $cm != ZLIB_CMF_CM_DEFLATED ; + + # Max window value is 7 for Deflate. + my $cinfo = bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS) ; + return $self->HeaderError("CINFO > " . ZLIB_CMF_CINFO_MAX . + " (CINFO is $cinfo)") + if $cinfo > ZLIB_CMF_CINFO_MAX ; + + return 1; +} + +sub bits +{ + my $data = shift ; + my $offset = shift ; + my $mask = shift ; + + ($data >> $offset ) & $mask & 0xFF ; +} + + +sub _readDeflateHeader +{ + my ($self, $buffer) = @_ ; + +# if (! $buffer) { +# $self->smartReadExact(\$buffer, ZLIB_HEADER_SIZE); +# +# *$self->{HeaderPending} = $buffer ; +# +# return $self->HeaderError("Header size is " . +# ZLIB_HEADER_SIZE . " bytes") +# if length $buffer != ZLIB_HEADER_SIZE; +# +# return $self->HeaderError("CRC mismatch.") +# if ! isZlibMagic($buffer) ; +# } + + my ($CMF, $FLG) = unpack "C C", $buffer; + my $FDICT = bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ), + + my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ; + $cm == ZLIB_CMF_CM_DEFLATED + or return $self->HeaderError("Not Deflate (CM is $cm)") ; + + my $DICTID; + if ($FDICT) { + $self->smartReadExact(\$buffer, ZLIB_FDICT_SIZE) + or return $self->TruncatedHeader("FDICT"); + + $DICTID = unpack("N", $buffer) ; + } + + *$self->{Type} = 'rfc1950'; + + return { + 'Type' => 'rfc1950', + 'FingerprintLength' => ZLIB_HEADER_SIZE, + 'HeaderLength' => ZLIB_HEADER_SIZE, + 'TrailerLength' => ZLIB_TRAILER_SIZE, + 'Header' => $buffer, + + CMF => $CMF , + CM => bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS ), + CINFO => bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS ), + FLG => $FLG , + FCHECK => bits($FLG, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS), + FDICT => bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ), + FLEVEL => bits($FLG, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS ), + DICTID => $DICTID , + + }; +} + + + + +1 ; + +__END__ + + +=head1 NAME + + + +IO::Uncompress::Inflate - Read RFC 1950 files/buffers + + + +=head1 SYNOPSIS + + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + my $status = inflate $input => $output [,OPTS] + or die "inflate failed: $InflateError\n"; + + my $z = new IO::Uncompress::Inflate $input [OPTS] + or die "inflate failed: $InflateError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $InflateError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + + +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC 1950. + +For writing RFC 1950 files/buffers, see the companion module IO::Compress::Deflate. + + + + + +=head1 Functional Interface + +A top-level function, C<inflate>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + inflate $input => $output [,OPTS] + or die "inflate failed: $InflateError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 inflate $input => $output [, OPTS] + + +C<inflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, each element in the array must be a +filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<inflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the uncompressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<inflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + + + +=head2 Notes + + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + + + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<inflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<inflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<inflate> has +completed. + +This parameter defaults to 0. + + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + + + + + +=item C<< Append => 0|1 >> + +TODO + +=item C<< MultiStream => 0|1 >> + + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + + + + + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + + + +=back + + + + +=head2 Examples + +To read the contents of the file C<file1.txt.1950> and write the +compressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + my $input = "file1.txt.1950"; + my $output = "file1.txt"; + inflate $input => $output + or die "inflate failed: $InflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.1950" + or die "Cannot open 'file1.txt.1950': $!\n" ; + my $buffer ; + inflate $input => \$buffer + or die "inflate failed: $InflateError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.1950" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + inflate '</my/home/*.txt.1950>' => '</my/home/#1.txt>' + or die "inflate failed: $InflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + for my $input ( glob "/my/home/*.txt.1950" ) + { + my $output = $input; + $output =~ s/.1950// ; + inflate $input => $output + or die "Error compressing '$input': $InflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::Inflate is shown below + + + my $z = new IO::Uncompress::Inflate $input [OPTS] + or die "IO::Uncompress::Inflate failed: $InflateError\n"; + +Returns an C<IO::Uncompress::Inflate> object on success and undef on failure. +The variable C<$InflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::Inflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::Inflate object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + + + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/bufffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::Inflate will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + + + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + + + + + +=over 5 + +=item 1 + +The ADLER32 checksum field must be present. + +=item 2 + +The value of the ADLER32 field read must match the adler32 value of the +uncompressed data actually contained in the file. + +=back + + + + + + + + + + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to to determine what constitutes a line +terminator. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::Inflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::Inflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::Inflate at present. + +=over 5 + +=item :all + +Imports C<inflate> and C<$InflateError>. +Same as doing this + + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + + + + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/ext/IO_Compress_Zlib/lib/IO/Uncompress/RawInflate.pm b/ext/IO_Compress_Zlib/lib/IO/Uncompress/RawInflate.pm new file mode 100644 index 0000000000..a811e656de --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Uncompress/RawInflate.pm @@ -0,0 +1,1152 @@ +package IO::Uncompress::RawInflate ; +# for RFC1951 + +use strict ; +use warnings; +use bytes; + +use Compress::Raw::Zlib 2.004 ; +use IO::Compress::Base::Common 2.004 qw(:Status createSelfTiedObject); + +use IO::Uncompress::Base 2.004 ; +use IO::Uncompress::Adapter::Inflate 2.004 ; + + + + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError); + +$VERSION = '2.004'; +$RawInflateError = ''; + +@ISA = qw( Exporter IO::Uncompress::Base ); +@EXPORT_OK = qw( $RawInflateError rawinflate ) ; +%DEFLATE_CONSTANTS = (); +%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + + +sub new +{ + my $class = shift ; + my $obj = createSelfTiedObject($class, \$RawInflateError); + $obj->_create(undef, 0, @_); +} + +sub rawinflate +{ + my $obj = createSelfTiedObject(undef, \$RawInflateError); + return $obj->_inf(@_); +} + +sub getExtraParams +{ + return (); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + return 1; +} + +sub mkUncomp +{ + my $self = shift ; + my $class = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject( + $got->value('CRC32'), + $got->value('ADLER32'), + $got->value('Scan'), + ); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + my $magic = $self->ckMagic() + or return 0; + + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + return 1; + +} + + +sub ckMagic +{ + my $self = shift; + + return $self->_isRaw() ; +} + +sub readHeader +{ + my $self = shift; + my $magic = shift ; + + return { + 'Type' => 'rfc1951', + 'FingerprintLength' => 0, + 'HeaderLength' => 0, + 'TrailerLength' => 0, + 'Header' => '' + }; +} + +sub chkTrailer +{ + return STATUS_OK ; +} + +sub _isRaw +{ + my $self = shift ; + + my $got = $self->_isRawx(@_); + + if ($got) { + *$self->{Pending} = *$self->{HeaderPending} ; + } + else { + $self->pushBack(*$self->{HeaderPending}); + *$self->{Uncomp}->reset(); + } + *$self->{HeaderPending} = ''; + + return $got ; +} + +sub _isRawx +{ + my $self = shift ; + my $magic = shift ; + + $magic = '' unless defined $magic ; + + my $buffer = ''; + + $self->smartRead(\$buffer, *$self->{BlockSize}) >= 0 + or return $self->saveErrorString(undef, "No data to read"); + + my $temp_buf = $magic . $buffer ; + *$self->{HeaderPending} = $temp_buf ; + $buffer = ''; + my $status = *$self->{Uncomp}->uncompr(\$temp_buf, \$buffer, $self->smartEof()) ; + return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, STATUS_ERROR) + if $status == STATUS_ERROR; + + #my $buf_len = *$self->{Uncomp}->uncompressedBytes(); + my $buf_len = length $buffer; + + if ($status == STATUS_ENDSTREAM) { + if (*$self->{MultiStream} + && (length $temp_buf || ! $self->smartEof())){ + *$self->{NewStream} = 1 ; + *$self->{EndStream} = 0 ; + $self->pushBack($temp_buf); + } + else { + *$self->{EndStream} = 1 ; + $self->pushBack($temp_buf); + } + } + *$self->{HeaderPending} = $buffer ; + *$self->{InflatedBytesRead} = $buf_len ; + *$self->{TotalInflatedBytesRead} += $buf_len ; + *$self->{Type} = 'rfc1951'; + + $self->saveStatus(STATUS_OK); + + return { + 'Type' => 'rfc1951', + 'HeaderLength' => 0, + 'TrailerLength' => 0, + 'Header' => '' + }; +} + + +sub inflateSync +{ + my $self = shift ; + + # inflateSync is a no-op in Plain mode + return 1 + if *$self->{Plain} ; + + return 0 if *$self->{Closed} ; + #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; + return 0 if ! length *$self->{Pending} && *$self->{EndStream} ; + + # Disable CRC check + *$self->{Strict} = 0 ; + + my $status ; + while (1) + { + my $temp_buf ; + + if (length *$self->{Pending} ) + { + $temp_buf = *$self->{Pending} ; + *$self->{Pending} = ''; + } + else + { + $status = $self->smartRead(\$temp_buf, *$self->{BlockSize}) ; + return $self->saveErrorString(0, "Error Reading Data") + if $status < 0 ; + + if ($status == 0 ) { + *$self->{EndStream} = 1 ; + return $self->saveErrorString(0, "unexpected end of file", STATUS_ERROR); + } + } + + $status = *$self->{Uncomp}->sync($temp_buf) ; + + if ($status == STATUS_OK) + { + *$self->{Pending} .= $temp_buf ; + return 1 ; + } + + last unless $status == STATUS_ERROR ; + } + + return 0; +} + +#sub performScan +#{ +# my $self = shift ; +# +# my $status ; +# my $end_offset = 0; +# +# $status = $self->scan() +# #or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $self->errorNo) ; +# or return $self->saveErrorString(G_ERR, "Error Scanning: $status") +# +# $status = $self->zap($end_offset) +# or return $self->saveErrorString(G_ERR, "Error Zapping: $status"); +# #or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $self->errorNo) ; +# +# #(*$obj->{Deflate}, $status) = $inf->createDeflate(); +# +## *$obj->{Header} = *$inf->{Info}{Header}; +## *$obj->{UnCompSize_32bit} = +## *$obj->{BytesWritten} = *$inf->{UnCompSize_32bit} ; +## *$obj->{CompSize_32bit} = *$inf->{CompSize_32bit} ; +# +# +## if ( $outType eq 'buffer') +## { substr( ${ *$self->{Buffer} }, $end_offset) = '' } +## elsif ($outType eq 'handle' || $outType eq 'filename') { +## *$self->{FH} = *$inf->{FH} ; +## delete *$inf->{FH}; +## *$obj->{FH}->flush() ; +## *$obj->{Handle} = 1 if $outType eq 'handle'; +## +## #seek(*$obj->{FH}, $end_offset, SEEK_SET) +## *$obj->{FH}->seek($end_offset, SEEK_SET) +## or return $obj->saveErrorString(undef, $!, $!) ; +## } +# +#} + +sub scan +{ + my $self = shift ; + + return 1 if *$self->{Closed} ; + return 1 if !length *$self->{Pending} && *$self->{EndStream} ; + + my $buffer = '' ; + my $len = 0; + + $len = $self->_raw_read(\$buffer, 1) + while ! *$self->{EndStream} && $len >= 0 ; + + #return $len if $len < 0 ? $len : 0 ; + return $len < 0 ? 0 : 1 ; +} + +sub zap +{ + my $self = shift ; + + my $headerLength = *$self->{Info}{HeaderLength}; + my $block_offset = $headerLength + *$self->{Uncomp}->getLastBlockOffset(); + $_[0] = $headerLength + *$self->{Uncomp}->getEndOffset(); + #printf "# End $_[0], headerlen $headerLength \n";; + #printf "# block_offset $block_offset %x\n", $block_offset; + my $byte ; + ( $self->smartSeek($block_offset) && + $self->smartRead(\$byte, 1) ) + or return $self->saveErrorString(0, $!, $!); + + #printf "#byte is %x\n", unpack('C*',$byte); + *$self->{Uncomp}->resetLastBlockByte($byte); + #printf "#to byte is %x\n", unpack('C*',$byte); + + ( $self->smartSeek($block_offset) && + $self->smartWrite($byte) ) + or return $self->saveErrorString(0, $!, $!); + + #$self->smartSeek($end_offset, 1); + + return 1 ; +} + +sub createDeflate +{ + my $self = shift ; + my ($def, $status) = *$self->{Uncomp}->createDeflateStream( + -AppendOutput => 1, + -WindowBits => - MAX_WBITS, + -CRC32 => *$self->{Params}->value('CRC32'), + -ADLER32 => *$self->{Params}->value('ADLER32'), + ); + + return wantarray ? ($status, $def) : $def ; +} + + +1; + +__END__ + + +=head1 NAME + + + +IO::Uncompress::RawInflate - Read RFC 1951 files/buffers + + + +=head1 SYNOPSIS + + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + my $status = rawinflate $input => $output [,OPTS] + or die "rawinflate failed: $RawInflateError\n"; + + my $z = new IO::Uncompress::RawInflate $input [OPTS] + or die "rawinflate failed: $RawInflateError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $RawInflateError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + + +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC 1951. + +For writing RFC 1951 files/buffers, see the companion module IO::Compress::RawDeflate. + + + + + +=head1 Functional Interface + +A top-level function, C<rawinflate>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + rawinflate $input => $output [,OPTS] + or die "rawinflate failed: $RawInflateError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 rawinflate $input => $output [, OPTS] + + +C<rawinflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, each element in the array must be a +filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<rawinflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the uncompressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<rawinflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + + + +=head2 Notes + + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + + + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<rawinflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<rawinflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<rawinflate> has +completed. + +This parameter defaults to 0. + + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + + + + + +=item C<< Append => 0|1 >> + +TODO + +=item C<< MultiStream => 0|1 >> + + + +This option is a no-op. + + + + + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + + + +=back + + + + +=head2 Examples + +To read the contents of the file C<file1.txt.1951> and write the +compressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + my $input = "file1.txt.1951"; + my $output = "file1.txt"; + rawinflate $input => $output + or die "rawinflate failed: $RawInflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.1951" + or die "Cannot open 'file1.txt.1951': $!\n" ; + my $buffer ; + rawinflate $input => \$buffer + or die "rawinflate failed: $RawInflateError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.1951" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + rawinflate '</my/home/*.txt.1951>' => '</my/home/#1.txt>' + or die "rawinflate failed: $RawInflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + for my $input ( glob "/my/home/*.txt.1951" ) + { + my $output = $input; + $output =~ s/.1951// ; + rawinflate $input => $output + or die "Error compressing '$input': $RawInflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::RawInflate is shown below + + + my $z = new IO::Uncompress::RawInflate $input [OPTS] + or die "IO::Uncompress::RawInflate failed: $RawInflateError\n"; + +Returns an C<IO::Uncompress::RawInflate> object on success and undef on failure. +The variable C<$RawInflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::RawInflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::RawInflate object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + + + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/bufffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::RawInflate will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + + + +This option is a no-op. + + + + + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to to determine what constitutes a line +terminator. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::RawInflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::RawInflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::RawInflate at present. + +=over 5 + +=item :all + +Imports C<rawinflate> and C<$RawInflateError>. +Same as doing this + + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + + + + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/ext/IO_Compress_Zlib/lib/IO/Uncompress/Unzip.pm b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Unzip.pm new file mode 100644 index 0000000000..cab4d07538 --- /dev/null +++ b/ext/IO_Compress_Zlib/lib/IO/Uncompress/Unzip.pm @@ -0,0 +1,1539 @@ +package IO::Uncompress::Unzip; + +require 5.004 ; + +# for RFC1952 + +use strict ; +use warnings; +use bytes; + +use IO::Uncompress::RawInflate 2.004 ; +use IO::Compress::Base::Common 2.004 qw(:Status createSelfTiedObject); +use IO::Uncompress::Adapter::Identity 2.004 ; +use IO::Compress::Zlib::Extra 2.004 ; +use IO::Compress::Zip::Constants 2.004 ; + +use Compress::Raw::Zlib 2.004 qw(crc32) ; + +BEGIN +{ + eval { require IO::Uncompress::Adapter::Bunzip2 ; + import IO::Uncompress::Adapter::Bunzip2 } ; +} + + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup); + +$VERSION = '2.004'; +$UnzipError = ''; + +@ISA = qw(Exporter IO::Uncompress::RawInflate); +@EXPORT_OK = qw( $UnzipError unzip ); +%EXPORT_TAGS = %IO::Uncompress::RawInflate::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +%headerLookup = ( + ZIP_CENTRAL_HDR_SIG, \&skipCentralDirectory, + ZIP_END_CENTRAL_HDR_SIG, \&skipEndCentralDirectory, + ZIP64_END_CENTRAL_REC_HDR_SIG, \&skipCentralDirectory64Rec, + ZIP64_END_CENTRAL_LOC_HDR_SIG, \&skipCentralDirectory64Loc, + ZIP64_ARCHIVE_EXTRA_SIG, \&skipArchiveExtra, + ZIP64_DIGITAL_SIGNATURE_SIG, \&skipDigitalSignature, + ); + +sub new +{ + my $class = shift ; + my $obj = createSelfTiedObject($class, \$UnzipError); + $obj->_create(undef, 0, @_); +} + +sub unzip +{ + my $obj = createSelfTiedObject(undef, \$UnzipError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + use IO::Compress::Base::Common 2.004 qw(:Parse); + + + return ( +# # Zip header fields + 'Name' => [1, 1, Parse_any, undef], + +# 'Streaming' => [1, 1, Parse_boolean, 1], + ); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # unzip always needs crc32 + $got->value('CRC32' => 1); + + *$self->{UnzipData}{Name} = $got->value('Name'); + + return 1; +} + + +sub ckMagic +{ + my $self = shift; + + my $magic ; + $self->smartReadExact(\$magic, 4); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + 4 . " bytes") + if length $magic != 4 ; + + return $self->HeaderError("Bad Magic") + if ! _isZipMagic($magic) ; + + *$self->{Type} = 'zip'; + + return $magic ; +} + + + +sub readHeader +{ + my $self = shift; + my $magic = shift ; + + my $name = *$self->{UnzipData}{Name} ; + my $hdr = $self->_readZipHeader($magic) ; + + while (defined $hdr) + { + if (! defined $name || $hdr->{Name} eq $name) + { + return $hdr ; + } + + # skip the data + my $buffer; + if (*$self->{ZipData}{Streaming}) { + + while (1) { + + my $b; + my $status = $self->smartRead(\$b, 1024 * 16); + return undef + if $status <= 0 ; + + my $temp_buf; + my $out; + $status = *$self->{Uncomp}->uncompr(\$b, \$temp_buf, 0, $out); + + return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, + *$self->{Uncomp}{ErrorNo}) + if $self->saveStatus($status) == STATUS_ERROR; + + if ($status == STATUS_ENDSTREAM) { + *$self->{Uncomp}->reset(); + $self->pushBack($b) ; + last; + } + } + + # skip the trailer + $self->smartReadExact(\$buffer, $hdr->{TrailerLength}) + or return $self->saveErrorString(undef, "Truncated file"); + } + else { + my $c = $hdr->{CompressedLength}->get32bit(); + $self->smartReadExact(\$buffer, $c) + or return $self->saveErrorString(undef, "Truncated file"); + $buffer = ''; + } + + $self->chkTrailer($buffer) == STATUS_OK + or return $self->saveErrorString(undef, "Truncated file"); + + $hdr = $self->_readFullZipHeader(); + + return $self->saveErrorString(undef, "Cannot find '$name'") + if $self->smartEof(); + } + + return undef; +} + +sub chkTrailer +{ + my $self = shift; + my $trailer = shift; + + my ($sig, $CRC32, $cSize, $uSize) ; + my ($cSizeHi, $uSizeHi) = (0, 0); + if (*$self->{ZipData}{Streaming}) { + $sig = unpack ("V", substr($trailer, 0, 4)); + $CRC32 = unpack ("V", substr($trailer, 4, 4)); + + if (*$self->{ZipData}{Zip64} ) { + $cSize = U64::newUnpack_V64 substr($trailer, 8, 8); + $uSize = U64::newUnpack_V64 substr($trailer, 16, 8); + } + else { + $cSize = U64::newUnpack_V32 substr($trailer, 8, 4); + $uSize = U64::newUnpack_V32 substr($trailer, 12, 4); + } + + return $self->TrailerError("Data Descriptor signature, got $sig") + if $sig != ZIP_DATA_HDR_SIG; + } + else { + ($CRC32, $cSize, $uSize) = + (*$self->{ZipData}{Crc32}, + *$self->{ZipData}{CompressedLen}, + *$self->{ZipData}{UnCompressedLen}); + } + + if (*$self->{Strict}) { + return $self->TrailerError("CRC mismatch") + if $CRC32 != *$self->{ZipData}{CRC32} ; + + return $self->TrailerError("CSIZE mismatch.") + if ! $cSize->equal(*$self->{CompSize}); + + return $self->TrailerError("USIZE mismatch.") + if ! $uSize->equal(*$self->{UnCompSize}); + } + + my $reachedEnd = STATUS_ERROR ; + # check for central directory or end of central directory + while (1) + { + my $magic ; + my $got = $self->smartRead(\$magic, 4); + + return $self->saveErrorString(STATUS_ERROR, "Truncated file") + if $got != 4 && *$self->{Strict}; + + if ($got == 0) { + return STATUS_EOF ; + } + elsif ($got < 0) { + return STATUS_ERROR ; + } + elsif ($got < 4) { + $self->pushBack($magic) ; + return STATUS_OK ; + } + + my $sig = unpack("V", $magic) ; + + my $hdr; + if ($hdr = $headerLookup{$sig}) + { + if (&$hdr($self, $magic) != STATUS_OK ) { + if (*$self->{Strict}) { + return STATUS_ERROR ; + } + else { + $self->clearError(); + return STATUS_OK ; + } + } + + if ($sig == ZIP_END_CENTRAL_HDR_SIG) + { + return STATUS_OK ; + last; + } + } + elsif ($sig == ZIP_LOCAL_HDR_SIG) + { + $self->pushBack($magic) ; + return STATUS_OK ; + } + else + { + # put the data back + $self->pushBack($magic) ; + last; + } + } + + return $reachedEnd ; +} + +sub skipCentralDirectory +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 46 - 4) + or return $self->TrailerError("Minimum header size is " . + 46 . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + #my $versionMadeBy = unpack ("v", substr($buffer, 4-4, 2)); + #my $extractVersion = unpack ("v", substr($buffer, 6-4, 2)); + #my $gpFlag = unpack ("v", substr($buffer, 8-4, 2)); + #my $compressedMethod = unpack ("v", substr($buffer, 10-4, 2)); + #my $lastModTime = unpack ("V", substr($buffer, 12-4, 4)); + #my $crc32 = unpack ("V", substr($buffer, 16-4, 4)); + my $compressedLength = unpack ("V", substr($buffer, 20-4, 4)); + my $uncompressedLength = unpack ("V", substr($buffer, 24-4, 4)); + my $filename_length = unpack ("v", substr($buffer, 28-4, 2)); + my $extra_length = unpack ("v", substr($buffer, 30-4, 2)); + my $comment_length = unpack ("v", substr($buffer, 32-4, 2)); + #my $disk_start = unpack ("v", substr($buffer, 34-4, 2)); + #my $int_file_attrib = unpack ("v", substr($buffer, 36-4, 2)); + #my $ext_file_attrib = unpack ("V", substr($buffer, 38-4, 2)); + #my $lcl_hdr_offset = unpack ("V", substr($buffer, 42-4, 2)); + + + my $filename; + my $extraField; + my $comment ; + if ($filename_length) + { + $self->smartReadExact(\$filename, $filename_length) + or return $self->TruncatedTrailer("filename"); + $keep .= $filename ; + } + + if ($extra_length) + { + $self->smartReadExact(\$extraField, $extra_length) + or return $self->TruncatedTrailer("extra"); + $keep .= $extraField ; + } + + if ($comment_length) + { + $self->smartReadExact(\$comment, $comment_length) + or return $self->TruncatedTrailer("comment"); + $keep .= $comment ; + } + + return STATUS_OK ; +} + +sub skipArchiveExtra +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 4) + or return $self->TrailerError("Minimum header size is " . + 4 . " bytes") ; + + my $keep = $magic . $buffer ; + + my $size = unpack ("V", $buffer); + + $self->smartReadExact(\$buffer, $size) + or return $self->TrailerError("Minimum header size is " . + $size . " bytes") ; + + $keep .= $buffer ; + *$self->{HeaderPending} = $keep ; + + return STATUS_OK ; +} + + +sub skipCentralDirectory64Rec +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 8) + or return $self->TrailerError("Minimum header size is " . + 8 . " bytes") ; + + my $keep = $magic . $buffer ; + + my ($sizeLo, $sizeHi) = unpack ("V V", $buffer); + + # TODO - take SizeHi into account + $self->smartReadExact(\$buffer, $sizeLo) + or return $self->TrailerError("Minimum header size is " . + $sizeLo . " bytes") ; + + $keep .= $buffer ; + *$self->{HeaderPending} = $keep ; + + #my $versionMadeBy = unpack ("v", substr($buffer, 0, 2)); + #my $extractVersion = unpack ("v", substr($buffer, 2, 2)); + #my $diskNumber = unpack ("V", substr($buffer, 4, 4)); + #my $cntrlDirDiskNo = unpack ("V", substr($buffer, 8, 4)); + #my $entriesInThisCD = unpack ("V V", substr($buffer, 12, 8)); + #my $entriesInCD = unpack ("V V", substr($buffer, 20, 8)); + #my $sizeOfCD = unpack ("V V", substr($buffer, 28, 8)); + #my $offsetToCD = unpack ("V V", substr($buffer, 36, 8)); + + return STATUS_OK ; +} + +sub skipCentralDirectory64Loc +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 20 - 4) + or return $self->TrailerError("Minimum header size is " . + 20 . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + #my $startCdDisk = unpack ("V", substr($buffer, 4-4, 4)); + #my $offsetToCD = unpack ("V V", substr($buffer, 8-4, 8)); + #my $diskCount = unpack ("V", substr($buffer, 16-4, 4)); + + return STATUS_OK ; +} + +sub skipEndCentralDirectory +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 22 - 4) + or return $self->TrailerError("Minimum header size is " . + 22 . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + #my $diskNumber = unpack ("v", substr($buffer, 4-4, 2)); + #my $cntrlDirDiskNo = unpack ("v", substr($buffer, 6-4, 2)); + #my $entriesInThisCD = unpack ("v", substr($buffer, 8-4, 2)); + #my $entriesInCD = unpack ("v", substr($buffer, 10-4, 2)); + #my $sizeOfCD = unpack ("V", substr($buffer, 12-4, 2)); + #my $offsetToCD = unpack ("V", substr($buffer, 16-4, 2)); + my $comment_length = unpack ("v", substr($buffer, 20-4, 2)); + + + my $comment ; + if ($comment_length) + { + $self->smartReadExact(\$comment, $comment_length) + or return $self->TruncatedTrailer("comment"); + $keep .= $comment ; + } + + return STATUS_OK ; +} + + +sub _isZipMagic +{ + my $buffer = shift ; + return 0 if length $buffer < 4 ; + my $sig = unpack("V", $buffer) ; + return $sig == ZIP_LOCAL_HDR_SIG ; +} + + +sub _readFullZipHeader($) +{ + my ($self) = @_ ; + my $magic = '' ; + + $self->smartReadExact(\$magic, 4); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + 30 . " bytes") + if length $magic != 4 ; + + + return $self->HeaderError("Bad Magic") + if ! _isZipMagic($magic) ; + + my $status = $self->_readZipHeader($magic); + delete *$self->{Transparent} if ! defined $status ; + return $status ; +} + +sub _readZipHeader($) +{ + my ($self, $magic) = @_ ; + my ($HeaderCRC) ; + my ($buffer) = '' ; + + $self->smartReadExact(\$buffer, 30 - 4) + or return $self->HeaderError("Minimum header size is " . + 30 . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + my $extractVersion = unpack ("v", substr($buffer, 4-4, 2)); + my $gpFlag = unpack ("v", substr($buffer, 6-4, 2)); + my $compressedMethod = unpack ("v", substr($buffer, 8-4, 2)); + my $lastModTime = unpack ("V", substr($buffer, 10-4, 4)); + my $crc32 = unpack ("V", substr($buffer, 14-4, 4)); + my $compressedLength = new U64 unpack ("V", substr($buffer, 18-4, 4)); + my $uncompressedLength = new U64 unpack ("V", substr($buffer, 22-4, 4)); + my $filename_length = unpack ("v", substr($buffer, 26-4, 2)); + my $extra_length = unpack ("v", substr($buffer, 28-4, 2)); + + my $filename; + my $extraField; + my @EXTRA = (); + my $streamingMode = ($gpFlag & ZIP_GP_FLAG_STREAMING_MASK) ? 1 : 0 ; + + return $self->HeaderError("Streamed Stored content not supported") + if $streamingMode && $compressedMethod == 0 ; + + return $self->HeaderError("Encrypted content not supported") + if $gpFlag & (ZIP_GP_FLAG_ENCRYPTED_MASK|ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK); + + return $self->HeaderError("Patch content not supported") + if $gpFlag & ZIP_GP_FLAG_PATCHED_MASK; + + *$self->{ZipData}{Streaming} = $streamingMode; + + + if ($filename_length) + { + $self->smartReadExact(\$filename, $filename_length) + or return $self->TruncatedHeader("Filename"); + $keep .= $filename ; + } + + my $zip64 = 0 ; + + if ($extra_length) + { + $self->smartReadExact(\$extraField, $extra_length) + or return $self->TruncatedHeader("Extra Field"); + + my $bad = IO::Compress::Zlib::Extra::parseRawExtra($extraField, + \@EXTRA, 1, 0); + return $self->HeaderError($bad) + if defined $bad; + + $keep .= $extraField ; + + my %Extra ; + for (@EXTRA) + { + $Extra{$_->[0]} = \$_->[1]; + } + + if (defined $Extra{ZIP_EXTRA_ID_ZIP64()}) + { + $zip64 = 1 ; + + my $buff = ${ $Extra{ZIP_EXTRA_ID_ZIP64()} }; + + # TODO - This code assumes that all the fields in the Zip64 + # extra field aren't necessarily present. The spec says that + # they only exist if the equivalent local headers are -1. + # Need to check that info-zip fills out -1 in the local header + # correctly. + + if (! $streamingMode) { + my $offset = 0 ; + + $uncompressedLength = U64::newUnpack_V64 substr($buff, 0, 8) + if $uncompressedLength == 0xFFFF ; + + $offset += 8 ; + + $compressedLength = U64::newUnpack_V64 substr($buff, $offset, 8) + if $compressedLength == 0xFFFF ; + + $offset += 8 ; + + #my $cheaderOffset = U64::newUnpack_V64 substr($buff, 16, 8); + #my $diskNumber = unpack ("V", substr($buff, 24, 4)); + } + } + } + + *$self->{ZipData}{Zip64} = $zip64; + + if (! $streamingMode) { + *$self->{ZipData}{Streaming} = 0; + *$self->{ZipData}{Crc32} = $crc32; + *$self->{ZipData}{CompressedLen} = $compressedLength; + *$self->{ZipData}{UnCompressedLen} = $uncompressedLength; + *$self->{CompressedInputLengthRemaining} = + *$self->{CompressedInputLength} = $compressedLength->get32bit(); + } + + *$self->{ZipData}{Method} = $compressedMethod; + if ($compressedMethod == ZIP_CM_DEFLATE) + { + *$self->{Type} = 'zip-deflate'; + } + elsif ($compressedMethod == ZIP_CM_BZIP2) + { + #if (! defined $IO::Uncompress::Adapter::Bunzip2::VERSION) + + *$self->{Type} = 'zip-bzip2'; + + my $obj = IO::Uncompress::Adapter::Bunzip2::mkUncompObject( + ); + + *$self->{Uncomp} = $obj; + *$self->{ZipData}{CRC32} = crc32(undef); + + } + elsif ($compressedMethod == ZIP_CM_STORE) + { + # TODO -- add support for reading uncompressed + + *$self->{Type} = 'zip-stored'; + + my $obj = IO::Uncompress::Adapter::Identity::mkUncompObject(# $got->value('CRC32'), + # $got->value('ADLER32'), + ); + + *$self->{Uncomp} = $obj; + + } + else + { + return $self->HeaderError("Unsupported Compression format $compressedMethod"); + } + + return { + 'Type' => 'zip', + 'FingerprintLength' => 4, + #'HeaderLength' => $compressedMethod == 8 ? length $keep : 0, + 'HeaderLength' => length $keep, + 'Zip64' => $zip64, + 'TrailerLength' => ! $streamingMode ? 0 : $zip64 ? 24 : 16, + 'Header' => $keep, + 'CompressedLength' => $compressedLength , + 'UncompressedLength' => $uncompressedLength , + 'CRC32' => $crc32 , + 'Name' => $filename, + 'Time' => _dosToUnixTime($lastModTime), + 'Stream' => $streamingMode, + + 'MethodID' => $compressedMethod, + 'MethodName' => $compressedMethod == ZIP_CM_DEFLATE + ? "Deflated" + : $compressedMethod == ZIP_CM_BZIP2 + ? "Bzip2" + : $compressedMethod == ZIP_CM_STORE + ? "Stored" + : "Unknown" , + +# 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0, +# 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0, +# 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0, +# 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0, +# 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0, +# 'Comment' => $comment, +# 'OsID' => $os, +# 'OsName' => defined $GZIP_OS_Names{$os} +# ? $GZIP_OS_Names{$os} : "Unknown", +# 'HeaderCRC' => $HeaderCRC, +# 'Flags' => $flag, +# 'ExtraFlags' => $xfl, + 'ExtraFieldRaw' => $extraField, + 'ExtraField' => [ @EXTRA ], + + + } +} + +sub filterUncompressed +{ + my $self = shift ; + + if (*$self->{ZipData}{Method} == 12) { + *$self->{ZipData}{CRC32} = crc32(${$_[0]}, *$self->{ZipData}{CRC32}); + } + else { + *$self->{ZipData}{CRC32} = *$self->{Uncomp}->crc32() ; + } +} + + +# from Archive::Zip +sub _dosToUnixTime +{ + #use Time::Local 'timelocal_nocheck'; + use Time::Local 'timelocal'; + + my $dt = shift; + + my $year = ( ( $dt >> 25 ) & 0x7f ) + 80; + my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1; + my $mday = ( ( $dt >> 16 ) & 0x1f ); + + my $hour = ( ( $dt >> 11 ) & 0x1f ); + my $min = ( ( $dt >> 5 ) & 0x3f ); + my $sec = ( ( $dt << 1 ) & 0x3e ); + + # catch errors + my $time_t = + eval { timelocal( $sec, $min, $hour, $mday, $mon, $year ); }; + return 0 + if $@; + return $time_t; +} + + +1; + +__END__ + + +=head1 NAME + + + +IO::Uncompress::Unzip - Read zip files/buffers + + + +=head1 SYNOPSIS + + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + my $status = unzip $input => $output [,OPTS] + or die "unzip failed: $UnzipError\n"; + + my $z = new IO::Uncompress::Unzip $input [OPTS] + or die "unzip failed: $UnzipError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $UnzipError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + + +This module provides a Perl interface that allows the reading of +zlib files/buffers. + +For writing zip files/buffers, see the companion module IO::Compress::Zip. + + + + + +=head1 Functional Interface + +A top-level function, C<unzip>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + unzip $input => $output [,OPTS] + or die "unzip failed: $UnzipError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 unzip $input => $output [, OPTS] + + +C<unzip> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, each element in the array must be a +filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<unzip> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the uncompressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<unzip> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + + + +=head2 Notes + + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + + + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<unzip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<unzip> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<unzip> has +completed. + +This parameter defaults to 0. + + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + + + + + +=item C<< Append => 0|1 >> + +TODO + +=item C<< MultiStream => 0|1 >> + + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + + + + + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + + + +=back + + + + +=head2 Examples + +To read the contents of the file C<file1.txt.zip> and write the +compressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + my $input = "file1.txt.zip"; + my $output = "file1.txt"; + unzip $input => $output + or die "unzip failed: $UnzipError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.zip" + or die "Cannot open 'file1.txt.zip': $!\n" ; + my $buffer ; + unzip $input => \$buffer + or die "unzip failed: $UnzipError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.zip" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + unzip '</my/home/*.txt.zip>' => '</my/home/#1.txt>' + or die "unzip failed: $UnzipError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + for my $input ( glob "/my/home/*.txt.zip" ) + { + my $output = $input; + $output =~ s/.zip// ; + unzip $input => $output + or die "Error compressing '$input': $UnzipError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::Unzip is shown below + + + my $z = new IO::Uncompress::Unzip $input [OPTS] + or die "IO::Uncompress::Unzip failed: $UnzipError\n"; + +Returns an C<IO::Uncompress::Unzip> object on success and undef on failure. +The variable C<$UnzipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::Unzip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::Unzip object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + + + +Treats the complete zip file/buffer as a single compressed data +stream. When reading in multi-stream mode each member of the zip +file/buffer will be uncompressed in turn until the end of the file/buffer +is encountered. + +This parameter defaults to 0. + + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/bufffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::Unzip will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + + + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + + + + + + + + + + + + + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to to determine what constitutes a line +terminator. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::Unzip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::Unzip +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + + + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::Unzip at present. + +=over 5 + +=item :all + +Imports C<unzip> and C<$UnzipError>. +Same as doing this + + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + + + + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2007 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/ext/IO_Compress_Zlib/private/MakeUtil.pm b/ext/IO_Compress_Zlib/private/MakeUtil.pm new file mode 100644 index 0000000000..af86677a41 --- /dev/null +++ b/ext/IO_Compress_Zlib/private/MakeUtil.pm @@ -0,0 +1,297 @@ +package MakeUtil ; +package main ; + +use strict ; + +use Config qw(%Config); +use File::Copy; + + +BEGIN +{ + eval { require File::Spec::Functions ; File::Spec::Functions->import() } ; + if ($@) + { + *catfile = sub { return "$_[0]/$_[1]" } + } +} + +require VMS::Filespec if $^O eq 'VMS'; + + +unless($ENV{PERL_CORE}) { + $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV; +} + +$ENV{SKIP_FOR_CORE} = 1 if $ENV{PERL_CORE} || $ENV{MY_PERL_CORE} ; + + + +sub MY::libscan +{ + my $self = shift; + my $path = shift; + + return undef + if $path =~ /(~|\.bak|_bak)$/ || + $path =~ /\..*\.sw(o|p)$/ || + $path =~ /\B\.svn\b/; + + return $path; +} + +sub MY::postamble +{ + return '' + if $ENV{PERL_CORE} ; + + my @files = getPerlFiles('MANIFEST'); + + my $postamble = ' + +MyTrebleCheck: + @echo Checking for $$^W in files: '. "@files" . ' + @perl -ne \' \ + exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/; \ + \' ' . " @files || " . ' \ + (echo found unexpected $$^W ; exit 1) + @echo All is ok. + +'; + + return $postamble; +} + +sub getPerlFiles +{ + my @manifests = @_ ; + + my @files = (); + + for my $manifest (@manifests) + { + my $prefix = './'; + + $prefix = $1 + if $manifest =~ m#^(.*/)#; + + open M, "<$manifest" + or die "Cannot open '$manifest': $!\n"; + while (<M>) + { + chomp ; + next if /^\s*#/ || /^\s*$/ ; + + s/^\s+//; + s/\s+$//; + + /^(\S+)\s*(.*)$/; + + my ($file, $rest) = ($1, $2); + + if ($file =~ /\.(pm|pl|t)$/ and $file !~ /MakeUtil.pm/) + { + push @files, "$prefix$file"; + } + elsif ($rest =~ /perl/i) + { + push @files, "$prefix$file"; + } + + } + close M; + } + + return @files; +} + +sub UpDowngrade +{ + return if defined $ENV{TipTop}; + + my @files = @_ ; + + # our and use bytes/utf8 is stable from 5.6.0 onward + # warnings is stable from 5.6.1 onward + + # Note: this code assumes that each statement it modifies is not + # split across multiple lines. + + + my $warn_sub = ''; + my $our_sub = '' ; + + my $upgrade ; + my $downgrade ; + my $do_downgrade ; + + my $caller = (caller(1))[3] || ''; + + if ($caller =~ /downgrade/) + { + $downgrade = 1; + } + elsif ($caller =~ /upgrade/) + { + $upgrade = 1; + } + else + { + $do_downgrade = 1 + if $] < 5.006001 ; + } + +# else +# { +# my $opt = shift @ARGV || '' ; +# $upgrade = ($opt =~ /^-upgrade/i); +# $downgrade = ($opt =~ /^-downgrade/i); +# push @ARGV, $opt unless $downgrade || $upgrade; +# } + + + if ($downgrade || $do_downgrade) { + # From: use|no warnings "blah" + # To: local ($^W) = 1; # use|no warnings "blah" + $warn_sub = sub { + s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; + s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; + }; + } + #elsif ($] >= 5.006001 || $upgrade) { + elsif ($upgrade) { + # From: local ($^W) = 1; # use|no warnings "blah" + # To: use|no warnings "blah" + $warn_sub = sub { + s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; + }; + } + + if ($downgrade || $do_downgrade) { + $our_sub = sub { + if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) { + my $indent = $1; + my $vars = join ' ', split /\s*,\s*/, $2; + $_ = "${indent}use vars qw($vars);\n"; + } + elsif ( /^(\s*)((use|no)\s+(bytes|utf8)\s*;.*)$/) + { + $_ = "$1# $2\n"; + } + }; + } + #elsif ($] >= 5.006000 || $upgrade) { + elsif ($upgrade) { + $our_sub = sub { + if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) { + my $indent = $1; + my $vars = join ', ', split ' ', $2; + $_ = "${indent}our ($vars);\n"; + } + elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/) + { + $_ = "$1$2\n"; + } + }; + } + + if (! $our_sub && ! $warn_sub) { + warn "Up/Downgrade not needed.\n"; + if ($upgrade || $downgrade) + { exit 0 } + else + { return } + } + + foreach (@files) { + #if (-l $_ ) + { doUpDown($our_sub, $warn_sub, $_) } + #else + #{ doUpDownViaCopy($our_sub, $warn_sub, $_) } + } + + warn "Up/Downgrade complete.\n" ; + exit 0 if $upgrade || $downgrade; + +} + + +sub doUpDown +{ + my $our_sub = shift; + my $warn_sub = shift; + + return if -d $_[0]; + + local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak"; + local (@ARGV) = shift; + + while (<>) + { + print, last if /^__(END|DATA)__/ ; + + &{ $our_sub }() if $our_sub ; + &{ $warn_sub }() if $warn_sub ; + print ; + } + + return if eof ; + + while (<>) + { print } +} + +sub doUpDownViaCopy +{ + my $our_sub = shift; + my $warn_sub = shift; + my $file = shift ; + + use File::Copy ; + + return if -d $file ; + + my $backup = $file . ($^O eq 'VMS') ? "_bak" : ".bak"; + + copy($file, $backup) + or die "Cannot copy $file to $backup: $!"; + + my @keep = (); + + { + open F, "<$file" + or die "Cannot open $file: $!\n" ; + while (<F>) + { + if (/^__(END|DATA)__/) + { + push @keep, $_; + last ; + } + + &{ $our_sub }() if $our_sub ; + &{ $warn_sub }() if $warn_sub ; + push @keep, $_; + } + + if (! eof F) + { + while (<F>) + { push @keep, $_ } + } + close F; + } + + { + open F, ">$file" + or die "Cannot open $file: $!\n"; + print F @keep ; + close F; + } +} + +package MakeUtil ; + +1; + + diff --git a/ext/IO_Compress_Zlib/t/001zlib-generic-deflate.t b/ext/IO_Compress_Zlib/t/001zlib-generic-deflate.t new file mode 100644 index 0000000000..a988ab9791 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/001zlib-generic-deflate.t @@ -0,0 +1,20 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "zlib-generic.pl" ; diff --git a/ext/IO_Compress_Zlib/t/001zlib-generic-gzip.t b/ext/IO_Compress_Zlib/t/001zlib-generic-gzip.t new file mode 100644 index 0000000000..db9101d91f --- /dev/null +++ b/ext/IO_Compress_Zlib/t/001zlib-generic-gzip.t @@ -0,0 +1,20 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "zlib-generic.pl" ; diff --git a/ext/IO_Compress_Zlib/t/001zlib-generic-rawdeflate.t b/ext/IO_Compress_Zlib/t/001zlib-generic-rawdeflate.t new file mode 100644 index 0000000000..4c491eb3a2 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/001zlib-generic-rawdeflate.t @@ -0,0 +1,20 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "zlib-generic.pl" ; diff --git a/ext/IO_Compress_Zlib/t/001zlib-generic-zip.t b/ext/IO_Compress_Zlib/t/001zlib-generic-zip.t new file mode 100644 index 0000000000..a9c755537f --- /dev/null +++ b/ext/IO_Compress_Zlib/t/001zlib-generic-zip.t @@ -0,0 +1,20 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "zlib-generic.pl" ; diff --git a/ext/IO_Compress_Zlib/t/002any-deflate.t b/ext/IO_Compress_Zlib/t/002any-deflate.t new file mode 100644 index 0000000000..6a4387ef0c --- /dev/null +++ b/ext/IO_Compress_Zlib/t/002any-deflate.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + + +use IO::Uncompress::AnyInflate qw($AnyInflateError) ; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub getClass +{ + 'AnyInflate'; +} + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "any.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/002any-gzip.t b/ext/IO_Compress_Zlib/t/002any-gzip.t new file mode 100644 index 0000000000..e93625fdfa --- /dev/null +++ b/ext/IO_Compress_Zlib/t/002any-gzip.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Uncompress::AnyInflate qw($AnyInflateError) ; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub getClass +{ + 'AnyInflate'; +} + + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "any.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/002any-rawdeflate.t b/ext/IO_Compress_Zlib/t/002any-rawdeflate.t new file mode 100644 index 0000000000..ef716c60c1 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/002any-rawdeflate.t @@ -0,0 +1,28 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Uncompress::AnyInflate qw($AnyInflateError) ; +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub getClass +{ + 'AnyInflate'; +} + + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "any.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/002any-transparent.t b/ext/IO_Compress_Zlib/t/002any-transparent.t new file mode 100644 index 0000000000..bb26bbcac0 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/002any-transparent.t @@ -0,0 +1,72 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); + +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 15 + $extra ; + + use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ; + +} + +{ + + my $string = <<EOM; +This is not compressed data +EOM + + my $buffer = $string ; + + for my $file (0, 1) + { + title "AnyInflate with Non-compressed data (File $file)" ; + + my $lex = new LexFile my $output; + my $input ; + + if ($file) { + writeFile($output, $buffer); + $input = $output; + } + else { + $input = \$buffer; + } + + + my $unc ; + my $keep = $buffer ; + $unc = new IO::Uncompress::AnyInflate $input, -Transparent => 0 ; + ok ! $unc," no AnyInflate object when -Transparent => 0" ; + is $buffer, $keep ; + + $buffer = $keep ; + $unc = new IO::Uncompress::AnyInflate \$buffer, -Transparent => 1 ; + ok $unc, " AnyInflate object when -Transparent => 1" ; + + my $uncomp ; + ok $unc->read($uncomp) > 0 ; + ok $unc->eof() ; + #ok $unc->type eq $Type; + + is $uncomp, $string ; + } +} + +1; diff --git a/ext/IO_Compress_Zlib/t/002any-zip.t b/ext/IO_Compress_Zlib/t/002any-zip.t new file mode 100644 index 0000000000..27f1714899 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/002any-zip.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Uncompress::AnyInflate qw($AnyInflateError) ; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub getClass +{ + 'AnyInflate'; +} + + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "any.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/004gziphdr.t b/ext/IO_Compress_Zlib/t/004gziphdr.t new file mode 100644 index 0000000000..c09fc32852 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/004gziphdr.t @@ -0,0 +1,962 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + + plan tests => 910 + $extra ; + + use_ok('Compress::Raw::Zlib') ; + use_ok('IO::Compress::Gzip::Constants') ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + +} + + + +# Check the Gzip Header Parameters +#======================================== + +my $ThisOS_code = $Compress::Raw::Zlib::gzip_os_code; + +my $lex = new LexFile my $name ; + +{ + title "Check Defaults"; + # Check Name defaults undef, no name, no comment + # and Time can be explicitly set. + + my $hdr = readHeaderInfo($name, -Time => 1234); + + is $hdr->{Time}, 1234; + ok ! defined $hdr->{Name}; + is $hdr->{MethodName}, 'Deflated'; + is $hdr->{ExtraFlags}, 0; + is $hdr->{MethodID}, Z_DEFLATED; + is $hdr->{OsID}, $ThisOS_code ; + ok ! defined $hdr->{Comment} ; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{HeaderCRC} ; + ok ! $hdr->{isMinimalHeader} ; +} + +{ + + title "Check name can be different from filename" ; + # Check Name can be different from filename + # Comment and Extra can be set + # Can specify a zero Time + + my $comment = "This is a Comment" ; + my $extra = "A little something extra" ; + my $aname = "a new name" ; + my $hdr = readHeaderInfo $name, + -Strict => 0, + -Name => $aname, + -Comment => $comment, + -ExtraField => $extra, + -Time => 0 ; + + ok $hdr->{Time} == 0; + ok $hdr->{Name} eq $aname; + ok $hdr->{MethodName} eq 'Deflated'; + ok $hdr->{MethodID} == 8; + is $hdr->{ExtraFlags}, 0; + ok $hdr->{Comment} eq $comment ; + is $hdr->{OsID}, $ThisOS_code ; + ok ! $hdr->{isMinimalHeader} ; + ok ! defined $hdr->{HeaderCRC} ; +} + +{ + title "Check Time defaults to now" ; + + # Check Time defaults to now + # and that can have empty name, comment and extrafield + my $before = time ; + my $hdr = readHeaderInfo $name, + -TextFlag => 1, + -Name => "", + -Comment => "", + -ExtraField => ""; + my $after = time ; + + ok $hdr->{Time} >= $before ; + ok $hdr->{Time} <= $after ; + + ok defined $hdr->{Name} ; + ok $hdr->{Name} eq ""; + ok defined $hdr->{Comment} ; + ok $hdr->{Comment} eq ""; + ok defined $hdr->{ExtraFieldRaw} ; + ok $hdr->{ExtraFieldRaw} eq ""; + is $hdr->{ExtraFlags}, 0; + + ok ! $hdr->{isMinimalHeader} ; + ok $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + is $hdr->{OsID}, $ThisOS_code ; + +} + +{ + title "can have null extrafield" ; + + my $before = time ; + my $hdr = readHeaderInfo $name, + -strict => 0, + -Name => "a", + -Comment => "b", + -ExtraField => "\x00"; + my $after = time ; + + ok $hdr->{Time} >= $before ; + ok $hdr->{Time} <= $after ; + ok $hdr->{Name} eq "a"; + ok $hdr->{Comment} eq "b"; + is $hdr->{ExtraFlags}, 0; + ok $hdr->{ExtraFieldRaw} eq "\x00"; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + is $hdr->{OsID}, $ThisOS_code ; + +} + +{ + title "can have undef name, comment, time and extrafield" ; + + my $hdr = readHeaderInfo $name, + -Name => undef, + -Comment => undef, + -ExtraField => undef, + -Time => undef; + + ok $hdr->{Time} == 0; + ok ! defined $hdr->{Name} ; + ok ! defined $hdr->{Comment} ; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + is $hdr->{OsID}, $ThisOS_code ; + +} + +for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") +{ + title "Comment with $value" ; + + my $v = pack "H*", $value; + my $comment = "my${v}comment$v"; + my $hdr = readHeaderInfo $name, + Time => 0, + -TextFlag => 1, + -Name => "", + -Comment => $comment, + -ExtraField => ""; + my $after = time ; + + is $hdr->{Time}, 0 ; + + ok defined $hdr->{Name} ; + ok $hdr->{Name} eq ""; + ok defined $hdr->{Comment} ; + is $hdr->{Comment}, $comment; + ok defined $hdr->{ExtraFieldRaw} ; + ok $hdr->{ExtraFieldRaw} eq ""; + is $hdr->{ExtraFlags}, 0; + + ok ! $hdr->{isMinimalHeader} ; + ok $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + is $hdr->{OsID}, $ThisOS_code ; + +} + +{ + title "Check crchdr" ; + + my $hdr = readHeaderInfo $name, -HeaderCRC => 1; + + ok ! defined $hdr->{Name}; + is $hdr->{ExtraFlags}, 0; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok defined $hdr->{HeaderCRC} ; + is $hdr->{OsID}, $ThisOS_code ; +} + +{ + title "Check ExtraFlags" ; + + my $hdr = readHeaderInfo $name, -Level => Z_BEST_SPEED; + + ok ! defined $hdr->{Name}; + is $hdr->{ExtraFlags}, 2; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + + $hdr = readHeaderInfo $name, -Level => Z_BEST_COMPRESSION; + + ok ! defined $hdr->{Name}; + is $hdr->{ExtraFlags}, 4; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + + $hdr = readHeaderInfo $name, -Level => Z_BEST_COMPRESSION, + -ExtraFlags => 42; + + ok ! defined $hdr->{Name}; + is $hdr->{ExtraFlags}, 42; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + + +} + +{ + title "OS Code" ; + + for my $code ( -1, undef, '', 'fred' ) + { + my $code_name = defined $code ? "'$code'" : "'undef'"; + eval { new IO::Compress::Gzip $name, -OS_Code => $code } ; + like $@, mkErr("^IO::Compress::Gzip: Parameter 'OS_Code' must be an unsigned int, got $code_name"), + " Trap OS Code $code_name"; + } + + for my $code ( qw( 256 ) ) + { + eval { ok ! new IO::Compress::Gzip($name, OS_Code => $code) }; + like $@, mkErr("OS_Code must be between 0 and 255, got '$code'"), + " Trap OS Code $code"; + like $GzipError, "/OS_Code must be between 0 and 255, got '$code'/", + " Trap OS Code $code"; + } + + for my $code ( qw(0 1 12 254 255) ) + { + my $hdr = readHeaderInfo $name, OS_Code => $code; + + is $hdr->{OsID}, $code, " Code is $code" ; + } + + + +} + +{ + title 'Check ExtraField'; + + my @tests = ( + [1, ['AB' => ''] => [['AB'=>'']] ], + [1, {'AB' => ''} => [['AB'=>'']] ], + [1, ['AB' => 'Fred'] => [['AB'=>'Fred']] ], + [1, {'AB' => 'Fred'} => [['AB'=>'Fred']] ], + [1, ['Xx' => '','AB' => 'Fred'] => [['Xx' => ''],['AB'=>'Fred']] ], + [1, ['Xx' => '','Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred']] ], + [1, ['Xx' => '', + 'Xx' => 'Fred', + 'Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred'], + ['Xx'=>'Fred']] ], + [1, [ ['Xx' => 'a'], + ['AB' => 'Fred'] ] => [['Xx' => 'a'],['AB'=>'Fred']] ], + [0, {'AB' => 'Fred', + 'Pq' => 'r', + "\x01\x02" => "\x03"} => [['AB'=>'Fred'], + ['Pq'=>'r'], + ["\x01\x02"=>"\x03"]] ], + [1, ['AB' => 'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE] => + [['AB'=>'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE]] ], + ); + + foreach my $test (@tests) { + my ($order, $input, $result) = @$test ; + ok my $x = new IO::Compress::Gzip $name, + -ExtraField => $input, + -HeaderCRC => 1 + or diag "GzipError is $GzipError" ; ; + my $string = "abcd" ; + ok $x->write($string) ; + ok $x->close ; + #is GZreadFile($name), $string ; + + ok $x = new IO::Uncompress::Gunzip $name, + #-Strict => 1, + -ParseExtra => 1 + or diag "GunzipError is $GunzipError" ; ; + my $hdr = $x->getHeaderInfo(); + ok $hdr; + ok ! defined $hdr->{Name}; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok defined $hdr->{HeaderCRC} ; + + ok defined $hdr->{ExtraFieldRaw} ; + ok defined $hdr->{ExtraField} ; + + my $extra = $hdr->{ExtraField} ; + + if ($order) { + eq_array $extra, $result; + } else { + eq_set $extra, $result; + } + } + +} + +{ + title 'Write Invalid ExtraField'; + + my $prefix = 'Error with ExtraField Parameter: '; + my @tests = ( + [ sub{ "abc" } => "Not a scalar, array ref or hash ref"], + [ [ "a" ] => "Not even number of elements"], + [ [ "a" => "fred" ] => 'SubField ID not two chars long'], + [ [ "a\x00" => "fred" ] => 'SubField ID 2nd byte is 0x00'], + [ [ [ {}, "abc" ]] => "SubField ID is a reference"], + [ [ [ "ab", \1 ]] => "SubField Data is a reference"], + [ [ {"a" => "fred"} ] => "Not list of lists"], + [ [ ['ab'=>'x'],{"a" => "fred"} ] => "Not list of lists"], + [ [ ["aa"] ] => "SubField must have two parts"], + [ [ ["aa", "b", "c"] ] => "SubField must have two parts"], + [ [ ["ab" => 'x' x (GZIP_FEXTRA_SUBFIELD_MAX_SIZE + 1) ] ] + => "SubField Data too long"], + + [ { 'abc', 1 } => "SubField ID not two chars long"], + [ { \1 , "abc" } => "SubField ID not two chars long"], + [ { "ab", \1 } => "SubField Data is a reference"], + ); + + + + foreach my $test (@tests) { + my ($input, $string) = @$test ; + my $buffer ; + my $x ; + eval { $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input; }; + like $@, mkErr("$prefix$string"); + like $GzipError, "/$prefix$string/"; + ok ! $x ; + + } + +} + +{ + # Corrupt ExtraField + + my @tests = ( + ["Sub-field truncated", + "Error with ExtraField Parameter: Truncated in FEXTRA Body Section", + "Header Error: Truncated in FEXTRA Body Section", + ['a', undef, undef] ], + ["Length of field incorrect", + "Error with ExtraField Parameter: Truncated in FEXTRA Body Section", + "Header Error: Truncated in FEXTRA Body Section", + ["ab", 255, "abc"] ], + ["Length of 2nd field incorrect", + "Error with ExtraField Parameter: Truncated in FEXTRA Body Section", + "Header Error: Truncated in FEXTRA Body Section", + ["ab", 3, "abc"], ["de", 7, "x"] ], + ["Length of 2nd field incorrect", + "Error with ExtraField Parameter: SubField ID 2nd byte is 0x00", + "Header Error: SubField ID 2nd byte is 0x00", + ["a\x00", 3, "abc"], ["de", 7, "x"] ], + ); + + foreach my $test (@tests) + { + my $name = shift @$test; + my $gzip_error = shift @$test; + my $gunzip_error = shift @$test; + + title "Read Corrupt ExtraField - $name" ; + + my $input = ''; + + for my $field (@$test) + { + my ($id, $len, $data) = @$field; + + $input .= $id if defined $id ; + $input .= pack("v", $len) if defined $len ; + $input .= $data if defined $data; + } + #hexDump(\$input); + + my $buffer ; + my $x ; + eval {$x = new IO::Compress::Gzip \$buffer, -ExtraField => $input, Strict => 1; }; + like $@, mkErr("$gzip_error"), " $name"; + like $GzipError, "/$gzip_error/", " $name"; + + ok ! $x, " IO::Compress::Gzip fails"; + like $GzipError, "/$gzip_error/", " $name"; + + foreach my $check (0, 1) + { + ok $x = new IO::Compress::Gzip \$buffer, + ExtraField => $input, + Strict => 0 + or diag "GzipError is $GzipError" ; + my $string = "abcd" ; + $x->write($string) ; + $x->close ; + is anyUncompress(\$buffer), $string ; + + $x = new IO::Uncompress::Gunzip \$buffer, + Strict => 0, + Transparent => 0, + ParseExtra => $check; + if ($check) { + ok ! $x ; + like $GunzipError, "/^$gunzip_error/"; + } + else { + ok $x ; + } + + } + } +} + + +{ + title 'Check Minimal'; + + ok my $x = new IO::Compress::Gzip $name, -Minimal => 1; + my $string = "abcd" ; + ok $x->write($string) ; + ok $x->close ; + #is GZreadFile($name), $string ; + + ok $x = new IO::Uncompress::Gunzip $name ; + my $hdr = $x->getHeaderInfo(); + ok $hdr; + ok $hdr->{Time} == 0; + is $hdr->{ExtraFlags}, 0; + ok ! defined $hdr->{Name} ; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + is $hdr->{OsName}, 'Unknown' ; + is $hdr->{MethodName}, "Deflated"; + is $hdr->{Flags}, 0; + ok $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok $x->close ; +} + +{ + # Check Minimal + no comressed data + # This is the smallest possible gzip file (20 bytes) + + ok my $x = new IO::Compress::Gzip $name, -Minimal => 1; + ok $x->close ; + #ok GZreadFile($name) eq '' ; + + ok $x = new IO::Uncompress::Gunzip $name, -Append => 1 ; + my $data ; + my $status = 1; + + $status = $x->read($data) + while $status > 0; + is $status, 0 ; + is $data, ''; + ok ! $x->error() ; + ok $x->eof() ; + + my $hdr = $x->getHeaderInfo(); + ok $hdr; + + ok defined $hdr->{ISIZE} ; + is $hdr->{ISIZE}, 0; + + ok defined $hdr->{CRC32} ; + is $hdr->{CRC32}, 0; + + is $hdr->{Time}, 0; + ok ! defined $hdr->{Name} ; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + is $hdr->{OsName}, 'Unknown' ; + is $hdr->{MethodName}, "Deflated"; + is $hdr->{Flags}, 0; + ok $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok $x->close ; +} + +{ + # Header Corruption Tests + + my $string = <<EOM; +some text +EOM + + my $good = ''; + ok my $x = new IO::Compress::Gzip \$good, -HeaderCRC => 1 ; + ok $x->write($string) ; + ok $x->close ; + + { + title "Header Corruption - Fingerprint wrong 1st byte" ; + my $buffer = $good ; + substr($buffer, 0, 1) = 'x' ; + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + ok $GunzipError =~ /Header Error: Bad Magic/; + } + + { + title "Header Corruption - Fingerprint wrong 2nd byte" ; + my $buffer = $good ; + substr($buffer, 1, 1) = "\xFF" ; + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + ok $GunzipError =~ /Header Error: Bad Magic/; + #print "$GunzipError\n"; + } + + { + title "Header Corruption - CM not 8"; + my $buffer = $good ; + substr($buffer, 2, 1) = 'x' ; + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + like $GunzipError, '/Header Error: Not Deflate \(CM is \d+\)/'; + } + + { + title "Header Corruption - Use of Reserved Flags"; + my $buffer = $good ; + substr($buffer, 3, 1) = "\xff"; + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + like $GunzipError, '/Header Error: Use of Reserved Bits in FLG field./'; + } + + { + title "Header Corruption - Fail HeaderCRC"; + my $buffer = $good ; + substr($buffer, 10, 1) = chr((ord(substr($buffer, 10, 1)) + 1) & 0xFF); + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0, Strict => 1 + or print "# $GunzipError\n"; + like $GunzipError, '/Header Error: CRC16 mismatch/' + #or diag "buffer length " . length($buffer); + or hexDump(\$good), hexDump(\$buffer); + } +} + +{ + title "ExtraField max raw size"; + my $x ; + my $store = "x" x GZIP_FEXTRA_MAX_SIZE ; + my $z = new IO::Compress::Gzip(\$x, ExtraField => $store, Strict => 0) ; + ok $z, "Created IO::Compress::Gzip object" ; + my $gunz = new IO::Uncompress::Gunzip \$x, Strict => 0; + ok $gunz, "Created IO::Uncompress::Gunzip object" ; + my $hdr = $gunz->getHeaderInfo(); + ok $hdr; + + is $hdr->{ExtraFieldRaw}, $store ; +} + +{ + title "Header Corruption - ExtraField too big"; + my $x; + eval { new IO::Compress::Gzip(\$x, -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ;}; + like $@, mkErr('Error with ExtraField Parameter: Too Large'); + like $GzipError, '/Error with ExtraField Parameter: Too Large/'; +} + +{ + title "Header Corruption - Create Name with Illegal Chars"; + + my $x; + eval { new IO::Compress::Gzip \$x, -Name => "fred\x02" }; + like $@, mkErr('Non ISO 8859-1 Character found in Name'); + like $GzipError, '/Non ISO 8859-1 Character found in Name/'; + + ok my $gz = new IO::Compress::Gzip \$x, + -Strict => 0, + -Name => "fred\x02" ; + ok $gz->close(); + + ok ! new IO::Uncompress::Gunzip \$x, + -Transparent => 0, + -Strict => 1; + + like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Name/'; + ok my $gunzip = new IO::Uncompress::Gunzip \$x, + -Strict => 0; + + my $hdr = $gunzip->getHeaderInfo() ; + + is $hdr->{Name}, "fred\x02"; + +} + +{ + title "Header Corruption - Null Chars in Name"; + my $x; + eval { new IO::Compress::Gzip \$x, -Name => "\x00" }; + like $@, mkErr('Null Character found in Name'); + like $GzipError, '/Null Character found in Name/'; + + eval { new IO::Compress::Gzip \$x, -Name => "abc\x00" }; + like $@, mkErr('Null Character found in Name'); + like $GzipError, '/Null Character found in Name/'; + + ok my $gz = new IO::Compress::Gzip \$x, + -Strict => 0, + -Name => "abc\x00de" ; + ok $gz->close() ; + ok my $gunzip = new IO::Uncompress::Gunzip \$x, + -Strict => 0; + + my $hdr = $gunzip->getHeaderInfo() ; + + is $hdr->{Name}, "abc"; + +} + +{ + title "Header Corruption - Create Comment with Illegal Chars"; + + my $x; + eval { new IO::Compress::Gzip \$x, -Comment => "fred\x02" }; + like $@, mkErr('Non ISO 8859-1 Character found in Comment'); + like $GzipError, '/Non ISO 8859-1 Character found in Comment/'; + + ok my $gz = new IO::Compress::Gzip \$x, + -Strict => 0, + -Comment => "fred\x02" ; + ok $gz->close(); + + ok ! new IO::Uncompress::Gunzip \$x, Strict => 1, + -Transparent => 0; + + like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Comment/'; + ok my $gunzip = new IO::Uncompress::Gunzip \$x, Strict => 0; + + my $hdr = $gunzip->getHeaderInfo() ; + + is $hdr->{Comment}, "fred\x02"; + +} + +{ + title "Header Corruption - Null Char in Comment"; + my $x; + eval { new IO::Compress::Gzip \$x, -Comment => "\x00" }; + like $@, mkErr('Null Character found in Comment'); + like $GzipError, '/Null Character found in Comment/'; + + eval { new IO::Compress::Gzip \$x, -Comment => "abc\x00" } ; + like $@, mkErr('Null Character found in Comment'); + like $GzipError, '/Null Character found in Comment/'; + + ok my $gz = new IO::Compress::Gzip \$x, + -Strict => 0, + -Comment => "abc\x00de" ; + ok $gz->close() ; + ok my $gunzip = new IO::Uncompress::Gunzip \$x, + -Strict => 0; + + my $hdr = $gunzip->getHeaderInfo() ; + + is $hdr->{Comment}, "abc"; + +} + + +for my $index ( GZIP_MIN_HEADER_SIZE + 1 .. GZIP_MIN_HEADER_SIZE + GZIP_FEXTRA_HEADER_SIZE + 1) +{ + title "Header Corruption - Truncated in Extra"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1, Strict => 0, + -ExtraField => "hello" x 10 ; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + #my $lex = new LexFile my $name ; + #writeFile($name, $truncated) ; + + #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; + my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; + ok ! $g + or print "# $g\n" ; + + like($GunzipError, '/^Header Error: Truncated in FEXTRA/'); + + +} + +my $Name = "fred" ; + my $truncated ; +for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Name) -1) +{ + title "Header Corruption - Truncated in Name"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -Name => $Name; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + + my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; + ok ! $g + or print "# $g\n" ; + + like $GunzipError, '/^Header Error: Truncated in FNAME Section/'; + +} + +my $Comment = "comment" ; +for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Comment) -1) +{ + title "Header Corruption - Truncated in Comment"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -Comment => $Comment; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + #my $lex = new LexFile my $name ; + #writeFile($name, $truncated) ; + + #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; + my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; + ok ! $g + or print "# $g\n" ; + + like $GunzipError, '/^Header Error: Truncated in FCOMMENT Section/'; + +} + +for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + GZIP_FHCRC_SIZE -1) +{ + title "Header Corruption - Truncated in CRC"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + my $lex = new LexFile my $name ; + writeFile($name, $truncated) ; + + my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; + #my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; + ok ! $g + or print "# $g\n" ; + + like $GunzipError, '/^Header Error: Truncated in FHCRC Section/'; + +} + + +{ + # Trailer Corruption tests + + my $string = <<EOM; +some text +EOM + + my $good ; + { + ok my $x = new IO::Compress::Gzip \$good ; + ok $x->write($string) ; + ok $x->close ; + } + + writeFile($name, $good) ; + ok my $gunz = new IO::Uncompress::Gunzip $name, + -Strict => 1; + my $uncomp ; + 1 while $gunz->read($uncomp) > 0 ; + ok $gunz->close() ; + ok $uncomp eq $string + or print "# got [$uncomp] wanted [$string]\n";; + + foreach my $trim (-8 .. -1) + { + my $got = $trim + 8 ; + title "Trailer Corruption - Trailer truncated to $got bytes" ; + my $buffer = $good ; + my $expected_trailing = substr($good, -8, 8) ; + substr($expected_trailing, $trim) = ''; + + substr($buffer, $trim) = ''; + writeFile($name, $buffer) ; + + foreach my $strict (0, 1) + { + ok my $gunz = new IO::Uncompress::Gunzip $name, -Strict => $strict ; + my $uncomp ; + if ($strict) + { + ok $gunz->read($uncomp) < 0 ; + like $GunzipError, "/Trailer Error: trailer truncated. Expected 8 bytes, got $got/"; + } + else + { + ok $gunz->read($uncomp) > 0 ; + ok ! $GunzipError ; + my $expected = substr($buffer, - $got); + is $gunz->trailingData(), $expected_trailing; + } + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } + + { + title "Trailer Corruption - Length Wrong, CRC Correct" ; + my $buffer = $good ; + my $actual_len = unpack("V", substr($buffer, -4, 4)); + substr($buffer, -4, 4) = pack('V', $actual_len + 1); + writeFile($name, $buffer) ; + + foreach my $strict (0, 1) + { + ok my $gunz = new IO::Uncompress::Gunzip $name, + -Strict => $strict ; + my $uncomp ; + if ($strict) + { + ok $gunz->read($uncomp) < 0 ; + my $got_len = $actual_len + 1; + like $GunzipError, "/Trailer Error: ISIZE mismatch. Got $got_len, expected $actual_len/"; + } + else + { + ok $gunz->read($uncomp) > 0 ; + ok ! $GunzipError ; + #is $gunz->trailingData(), substr($buffer, - $got) ; + } + ok ! $gunz->trailingData() ; + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } + + { + title "Trailer Corruption - Length Correct, CRC Wrong" ; + my $buffer = $good ; + my $actual_crc = unpack("V", substr($buffer, -8, 4)); + substr($buffer, -8, 4) = pack('V', $actual_crc+1); + writeFile($name, $buffer) ; + + foreach my $strict (0, 1) + { + ok my $gunz = new IO::Uncompress::Gunzip $name, + -Strict => $strict ; + my $uncomp ; + if ($strict) + { + ok $gunz->read($uncomp) < 0 ; + like $GunzipError, '/Trailer Error: CRC mismatch/'; + } + else + { + ok $gunz->read($uncomp) > 0 ; + ok ! $GunzipError ; + } + ok ! $gunz->trailingData() ; + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } + + { + title "Trailer Corruption - Length Wrong, CRC Wrong" ; + my $buffer = $good ; + my $actual_len = unpack("V", substr($buffer, -4, 4)); + my $actual_crc = unpack("V", substr($buffer, -8, 4)); + substr($buffer, -4, 4) = pack('V', $actual_len+1); + substr($buffer, -8, 4) = pack('V', $actual_crc+1); + writeFile($name, $buffer) ; + + foreach my $strict (0, 1) + { + ok my $gunz = new IO::Uncompress::Gunzip $name, + -Strict => $strict ; + my $uncomp ; + if ($strict) + { + ok $gunz->read($uncomp) < 0 ; + like $GunzipError, '/Trailer Error: CRC mismatch/'; + } + else + { + ok $gunz->read($uncomp) > 0 ; + ok ! $GunzipError ; + } + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } +} + + + diff --git a/ext/IO_Compress_Zlib/t/005defhdr.t b/ext/IO_Compress_Zlib/t/005defhdr.t new file mode 100644 index 0000000000..6cdc175a9d --- /dev/null +++ b/ext/IO_Compress_Zlib/t/005defhdr.t @@ -0,0 +1,349 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 595 + $extra ; + + use_ok('Compress::Raw::Zlib') ; + + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; + + use_ok('IO::Compress::Zlib::Constants'); + +} + + +sub ReadHeaderInfo +{ + my $string = shift || '' ; + my %opts = @_ ; + + my $buffer ; + ok my $def = new IO::Compress::Deflate \$buffer, %opts ; + is $def->write($string), length($string) ; + ok $def->close ; + #print "ReadHeaderInfo\n"; hexDump(\$buffer); + + ok my $inf = new IO::Uncompress::Inflate \$buffer ; + my $uncomp ; + #ok $inf->read($uncomp) ; + my $actual = 0 ; + my $status = 1 ; + while (($status = $inf->read($uncomp)) > 0) { + $actual += $status ; + } + + is $actual, length($string) ; + is $uncomp, $string; + ok ! $inf->error() ; + ok $inf->eof() ; + ok my $hdr = $inf->getHeaderInfo(); + ok $inf->close ; + + return $hdr ; +} + +sub ReadHeaderInfoZlib +{ + my $string = shift || '' ; + my %opts = @_ ; + + my $buffer ; + ok my $def = new Compress::Raw::Zlib::Deflate AppendOutput => 1, %opts ; + cmp_ok $def->deflate($string, $buffer), '==', Z_OK; + cmp_ok $def->flush($buffer), '==', Z_OK; + #print "ReadHeaderInfoZlib\n"; hexDump(\$buffer); + + ok my $inf = new IO::Uncompress::Inflate \$buffer ; + my $uncomp ; + #ok $inf->read($uncomp) ; + my $actual = 0 ; + my $status = 1 ; + while (($status = $inf->read($uncomp)) > 0) { + $actual += $status ; + } + + is $actual, length($string) ; + is $uncomp, $string; + ok ! $inf->error() ; + ok $inf->eof() ; + ok my $hdr = $inf->getHeaderInfo(); + ok $inf->close ; + + return $hdr ; +} + +sub printHeaderInfo +{ + my $buffer = shift ; + my $inf = new IO::Uncompress::Inflate \$buffer ; + my $hdr = $inf->getHeaderInfo(); + + no warnings 'uninitialized' ; + while (my ($k, $v) = each %$hdr) { + print " $k -> $v\n" ; + } +} + + +# Check the Deflate Header Parameters +#======================================== + +my $lex = new LexFile my $name ; + +{ + title "Check default header settings" ; + + my $string = <<EOM; +some text +EOM + + my $hdr = ReadHeaderInfo($string); + + is $hdr->{CM}, 8, " CM is 8"; + is $hdr->{FDICT}, 0, " FDICT is 0"; + +} + +{ + title "Check user-defined header settings match zlib" ; + + my $string = <<EOM; +some text +EOM + + my @tests = ( + [ {-Level => 0}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Level => 1}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Level => 2}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], + [ {-Level => 3}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], + [ {-Level => 4}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], + [ {-Level => 5}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], + [ {-Level => 6}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], + [ {-Level => 7}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], + [ {-Level => 8}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], + [ {-Level => 9}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], + + [ {-Level => Z_NO_COMPRESSION }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Level => Z_BEST_SPEED }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Level => Z_BEST_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], + [ {-Level => Z_DEFAULT_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], + + [ {-Strategy => Z_HUFFMAN_ONLY}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Strategy => Z_HUFFMAN_ONLY, + -Level => 3 }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + ); + + foreach my $test (@tests) + { + my $opts = $test->[0] ; + my $expect = $test->[1] ; + + my @title ; + while (my ($k, $v) = each %$opts) + { + push @title, "$k => $v"; + } + title " Set @title"; + + my $hdr = ReadHeaderInfo($string, %$opts); + + my $hdr1 = ReadHeaderInfoZlib($string, %$opts); + + is $hdr->{CM}, 8, " CM is 8"; + is $hdr->{CINFO}, 7, " CINFO is 7"; + is $hdr->{FDICT}, 0, " FDICT is 0"; + + while (my ($k, $v) = each %$expect) + { + if (ZLIB_VERNUM >= 0x1220) + { is $hdr->{$k}, $v, " $k is $v" } + else + { ok 1, " Skip test for $k" } + } + + is $hdr->{CM}, $hdr1->{CM}, " CM matches"; + is $hdr->{CINFO}, $hdr1->{CINFO}, " CINFO matches"; + is $hdr->{FDICT}, $hdr1->{FDICT}, " FDICT matches"; + is $hdr->{FLEVEL}, $hdr1->{FLEVEL}, " FLEVEL matches"; + is $hdr->{FCHECK}, $hdr1->{FCHECK}, " FCHECK matches"; + } + + +} + +{ + title "No compressed data at all"; + + my $hdr = ReadHeaderInfo(""); + + is $hdr->{CM}, 8, " CM is 8"; + is $hdr->{FDICT}, 0, " FDICT is 0"; + + ok defined $hdr->{ADLER32}, " ADLER32 is defined" ; + is $hdr->{ADLER32}, 1, " ADLER32 is 1"; +} + +{ + # Header Corruption Tests + + my $string = <<EOM; +some text +EOM + + my $good ; + ok my $x = new IO::Compress::Deflate \$good ; + ok $x->write($string) ; + ok $x->close ; + + { + title "Header Corruption - FCHECK failure - 1st byte wrong"; + my $buffer = $good ; + substr($buffer, 0, 1) = "\x00" ; + + ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', + "CRC mismatch"; + } + + { + title "Header Corruption - FCHECK failure - 2nd byte wrong"; + my $buffer = $good ; + substr($buffer, 1, 1) = "\x00" ; + + ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', + "CRC mismatch"; + } + + + sub mkZlibHdr + { + my $method = shift ; + my $cinfo = shift ; + my $fdict = shift ; + my $level = shift ; + + my $cmf = ($method & 0x0F) ; + $cmf |= (($cinfo & 0x0F) << 4) ; + my $flg = (($level & 0x03) << 6) ; + $flg |= (($fdict & 0x01) << 5) ; + my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ; + $flg |= $fcheck ; + #print "check $fcheck\n"; + + return pack("CC", $cmf, $flg) ; + } + + { + title "Header Corruption - CM not 8"; + my $buffer = $good ; + my $header = mkZlibHdr(3, 6, 0, 3); + + substr($buffer, 0, 2) = $header; + + my $un = new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/', + " Not Deflate"; + } + +} + +{ + # Trailer Corruption tests + + my $string = <<EOM; +some text +EOM + + my $good ; + ok my $x = new IO::Compress::Deflate \$good ; + ok $x->write($string) ; + ok $x->close ; + + foreach my $trim (-4 .. -1) + { + my $got = $trim + 4 ; + foreach my $s (0, 1) + { + title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ; + my $buffer = $good ; + my $expected_trailing = substr($good, -4, 4) ; + substr($expected_trailing, $trim) = ''; + + substr($buffer, $trim) = ''; + writeFile($name, $buffer) ; + + ok my $gunz = new IO::Uncompress::Inflate $name, Strict => $s; + my $uncomp ; + if ($s) + { + ok $gunz->read($uncomp) < 0 ; + like $IO::Uncompress::Inflate::InflateError,"/Trailer Error: trailer truncated. Expected 4 bytes, got $got/", + "Trailer Error"; + } + else + { + is $gunz->read($uncomp), length $string ; + } + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } + + { + title "Trailer Corruption - CRC Wrong, strict" ; + my $buffer = $good ; + my $crc = unpack("N", substr($buffer, -4, 4)); + substr($buffer, -4, 4) = pack('N', $crc+1); + writeFile($name, $buffer) ; + + ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 1; + my $uncomp ; + ok $gunz->read($uncomp) < 0 ; + like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/', + "Trailer Error: CRC mismatch"; + ok $gunz->eof() ; + ok ! $gunz->trailingData() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + { + title "Trailer Corruption - CRC Wrong, no strict" ; + my $buffer = $good ; + my $crc = unpack("N", substr($buffer, -4, 4)); + substr($buffer, -4, 4) = pack('N', $crc+1); + writeFile($name, $buffer) ; + + ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 0; + my $uncomp ; + ok $gunz->read($uncomp) >= 0 ; + ok $gunz->eof() ; + ok ! $gunz->trailingData() ; + ok $uncomp eq $string; + ok $gunz->close ; + } +} + diff --git a/ext/IO_Compress_Zlib/t/010examples.t b/ext/IO_Compress_Zlib/t/010examples.t new file mode 100644 index 0000000000..35b8f5af5e --- /dev/null +++ b/ext/IO_Compress_Zlib/t/010examples.t @@ -0,0 +1,145 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); + +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; +use IO::Compress::Gzip 'gzip' ; + +BEGIN +{ + plan(skip_all => "Examples needs Perl 5.005 or better - you have Perl $]" ) + if $] < 5.005 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 19 + $extra ; +} + + +my $Inc = join " ", map qq["-I$_"] => @INC; +$Inc = '"-MExtUtils::testlib"' + if ! $ENV{PERL_CORE} && eval " require ExtUtils::testlib; " ; + +my $Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; +$Perl = qq["$Perl"] if $^O eq 'MSWin32' ; + +$Perl = "$Perl $Inc -w" ; +#$Perl .= " -Mblib " ; +my $examples = $ENV{PERL_CORE} ? "../ext/Compress/Zlib/examples" + : "./examples"; + +my $hello1 = <<EOM ; +hello +this is +a test +message +x ttttt +xuuuuuu +the end +EOM + +my @hello1 = grep(s/$/\n/, split(/\n/, $hello1)) ; + +my $hello2 = <<EOM; + +Howdy +this is the +second +file +x ppppp +xuuuuuu +really the end +EOM + +my @hello2 = grep(s/$/\n/, split(/\n/, $hello2)) ; + +my $file1 = "hello1.gz" ; +my $file2 = "hello2.gz" ; +my $stderr = "err.out" ; + +for ($file1, $file2, $stderr) { 1 while unlink $_ } ; + + +gzip \$hello1 => $file1 ; +gzip \$hello2 => $file2 ; + +sub check +{ + my $command = shift ; + my $expected = shift ; + + my $stderr = 'err.out'; + 1 while unlink $stderr; + + my $cmd = "$command 2>$stderr"; + my $stdout = `$cmd` ; + + my $aok = 1 ; + + $aok &= is $?, 0, " exit status is 0" ; + + $aok &= is readFile($stderr), '', " no stderr" ; + + $aok &= is $stdout, $expected, " expected content is ok" + if defined $expected ; + + if (! $aok) { + diag "Command line: $cmd"; + my ($file, $line) = (caller)[1,2]; + diag "Test called from $file, line $line"; + } + + 1 while unlink $stderr; +} + +# gzcat +# ##### + +title "gzcat - command line" ; +check "$Perl ${examples}/gzcat $file1 $file2", $hello1 . $hello2; + +title "gzcat - stdin" ; +check "$Perl ${examples}/gzcat <$file1 ", $hello1; + + +# gzgrep +# ###### + +title "gzgrep"; +check "$Perl ${examples}/gzgrep the $file1 $file2", + join('', grep(/the/, @hello1, @hello2)); + +for ($file1, $file2, $stderr) { 1 while unlink $_ } ; + + + +# gzstream +# ######## + +{ + title "gzstream" ; + writeFile($file1, $hello1) ; + check "$Perl ${examples}/gzstream <$file1 >$file2"; + + title "gzcat" ; + check "$Perl ${examples}/gzcat $file2", $hello1 ; +} + +END +{ + for ($file1, $file2, $stderr) { 1 while unlink $_ } ; +} + diff --git a/ext/IO_Compress_Zlib/t/020isize.t b/ext/IO_Compress_Zlib/t/020isize.t new file mode 100644 index 0000000000..c600c95f34 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/020isize.t @@ -0,0 +1,158 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict ; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; + +BEGIN +{ + plan skip_all => "Lengthy Tests Disabled\n" . + "set COMPRESS_ZLIB_RUN_ALL to run this test suite" + unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 76 + $extra ; + + + use_ok('Compress::Zlib', 2) ; + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + use_ok('IO::Compress::Gzip::Constants'); +} + +my $compressed ; +my $expected_crc ; + +for my $wrap (0 .. 2) +{ + for my $offset ( -1 .. 1 ) + { + next if $wrap == 0 && $offset < 0 ; + + title "Wrap $wrap, Offset $offset" ; + + my $size = (GZIP_ISIZE_MAX * $wrap) + $offset ; + + my $expected_isize ; + if ($wrap == 0) { + $expected_isize = $offset ; + } + elsif ($wrap == 1 && $offset <= 0) { + $expected_isize = GZIP_ISIZE_MAX + $offset ; + } + elsif ($wrap > 1) { + $expected_isize = GZIP_ISIZE_MAX + $offset - 1; + } + else { + $expected_isize = $offset - 1; + } + + sub gzipClosure + { + my $gzip = shift ; + my $max = shift ; + + my $index = 0 ; + my $inc = 1024 * 5000 ; + my $buff = 'x' x $inc ; + my $left = $max ; + + return + sub { + + if ($max == 0 && $index == 0) { + $expected_crc = crc32('') ; + ok $gzip->close(), ' IO::Compress::Gzip::close ok X' ; + ++ $index ; + $_[0] .= $compressed; + return length $compressed ; + } + + return 0 if $index >= $max ; + + while ( ! length $compressed ) + { + $index += $inc ; + + if ($index <= $max) { + $gzip->write($buff) ; + #print "Write " . length($buff) . "\n" ; + #print "# LEN Compressed " . length($compressed) . "\n" ; + $expected_crc = crc32($buff, $expected_crc) ; + $left -= $inc ; + } + else { + #print "Write $left\n" ; + $gzip->write('x' x $left) ; + #print "# LEN Compressed " . length($compressed) . "\n" ; + $expected_crc = crc32('x' x $left, $expected_crc) ; + ok $gzip->close(), ' IO::Compress::Gzip::close ok ' ; + last ; + } + } + + my $len = length $compressed ; + $_[0] .= $compressed ; + $compressed = ''; + #print "# LEN $len\n" if $len <=0 ; + + return $len ; + }; + } + + my $gzip = new IO::Compress::Gzip \$compressed, + -Append => 0, + -HeaderCRC => 1; + + ok $gzip, " Created IO::Compress::Gzip object"; + + my $gunzip = new IO::Uncompress::Gunzip gzipClosure($gzip, $size), + -BlockSize => 1024 * 500 , + -Append => 0, + -Strict => 1; + + ok $gunzip, " Created IO::Uncompress::Gunzip object"; + + my $inflate = *$gunzip->{Inflate} ; + my $deflate = *$gzip->{Deflate} ; + + my $status ; + my $uncompressed; + my $actual = 0 ; + while (($status = $gunzip->read($uncompressed)) > 0) { + #print "# READ $status\n" ; + $actual += $status ; + } + + is $status, 0, ' IO::Uncompress::Gunzip::read returned 0' + or diag "error status is $status, error is $GunzipError" ; + + ok $gunzip->close(), " IO::Uncompress::Gunzip Closed ok" ; + + is $actual, $size, " Length of Gunzipped data is $size" + or diag "Expected $size, got $actual"; + + my $gunzip_hdr = $gunzip->getHeaderInfo(); + + is $gunzip_hdr->{ISIZE}, $expected_isize, + sprintf(" ISIZE is $expected_isize [0x%X]", $expected_isize); + is $gunzip_hdr->{CRC32}, $expected_crc, + sprintf(" CRC32 is $expected_crc [0x%X]", $expected_crc); + + $expected_crc = 0 ; + } +} + diff --git a/ext/IO_Compress_Zlib/t/050interop-gzip.t b/ext/IO_Compress_Zlib/t/050interop-gzip.t new file mode 100644 index 0000000000..22be0646c8 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/050interop-gzip.t @@ -0,0 +1,143 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; + +my $GZIP ; + + +sub ExternalGzipWorks +{ + my $lex = new LexFile my $outfile; + my $content = qq { +Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Ut tempus odio id + dolor. Camelus perlus. Larrius in lumen numen. Dolor en quiquum filia + est. Quintus cenum parat. +}; + + writeWithGzip($outfile, $content) + or return 0; + + my $got ; + readWithGzip($outfile, $got) + or return 0; + + if ($content ne $got) + { + diag "Uncompressed content is wrong"; + return 0 ; + } + + return 1 ; +} + +sub readWithGzip +{ + my $file = shift ; + + my $lex = new LexFile my $outfile; + + my $comp = "$GZIP -dc" ; + + if ( system("$comp $file >$outfile") == 0 ) + { + $_[0] = readFile($outfile); + return 1 + } + + diag "'$comp' failed: $?"; + return 0 ; +} + +sub getGzipInfo +{ + my $file = shift ; +} + +sub writeWithGzip +{ + my $file = shift ; + my $content = shift ; + my $options = shift || ''; + + my $lex = new LexFile my $infile; + writeFile($infile, $content); + + unlink $file ; + my $comp = "$GZIP -c $options $infile >$file" ; + + return 1 + if system($comp) == 0 ; + + diag "'$comp' failed: $?"; + return 0 ; +} + +BEGIN { + + # Check external gzip is available + my $name = $^O =~ /mswin/i ? 'gzip.exe' : 'gzip'; + my $split = $^O =~ /mswin/i ? ";" : ":"; + + for my $dir (reverse split $split, $ENV{PATH}) + { + $GZIP = "$dir/$name" + if -x "$dir/$name" ; + } + + plan(skip_all => "Cannot find $name") + if ! $GZIP ; + + plan(skip_all => "$name doesn't work as expected") + if ! ExternalGzipWorks(); + + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 7 + $extra ; + + use_ok('IO::Compress::Gzip', ':all') ; + use_ok('IO::Uncompress::Gunzip', ':all') ; + +} + + +{ + title "Test interop with $GZIP" ; + + my $file; + my $file1; + my $lex = new LexFile $file, $file1; + my $content = qq { +Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Ut tempus odio id + dolor. Camelus perlus. Larrius in lumen numen. Dolor en quiquum filia + est. Quintus cenum parat. +}; + my $got; + + ok writeWithGzip($file, $content), "writeWithGzip ok"; + + gunzip $file => \$got ; + is $got, $content, "got content"; + + + gzip \$content => $file1; + $got = ''; + ok readWithGzip($file1, $got), "readWithGzip ok"; + is $got, $content, "got content"; +} + + diff --git a/ext/IO_Compress_Zlib/t/100generic-deflate.t b/ext/IO_Compress_Zlib/t/100generic-deflate.t new file mode 100644 index 0000000000..999c9561e2 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/100generic-deflate.t @@ -0,0 +1,22 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; +use bytes; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "generic.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/100generic-gzip.t b/ext/IO_Compress_Zlib/t/100generic-gzip.t new file mode 100644 index 0000000000..614945ca80 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/100generic-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + return 'IO::Compress::Gzip'; +} + +require "generic.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/100generic-rawdeflate.t b/ext/IO_Compress_Zlib/t/100generic-rawdeflate.t new file mode 100644 index 0000000000..b5a43697bd --- /dev/null +++ b/ext/IO_Compress_Zlib/t/100generic-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "generic.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/100generic-zip.t b/ext/IO_Compress_Zlib/t/100generic-zip.t new file mode 100644 index 0000000000..907dada4c5 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/100generic-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "generic.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/101truncate-deflate.t b/ext/IO_Compress_Zlib/t/101truncate-deflate.t new file mode 100644 index 0000000000..2ae2b312df --- /dev/null +++ b/ext/IO_Compress_Zlib/t/101truncate-deflate.t @@ -0,0 +1,37 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use Test::More ; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 734 + $extra; + +}; + + +#use Test::More skip_all => "not implemented yet"; + + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "truncate.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/101truncate-gzip.t b/ext/IO_Compress_Zlib/t/101truncate-gzip.t new file mode 100644 index 0000000000..1e546b47e9 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/101truncate-gzip.t @@ -0,0 +1,36 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +#use Test::More skip_all => "not implemented yet"; +use Test::More ; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 978 + $extra; + +}; + + + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + return 'IO::Compress::Gzip'; +} + +require "truncate.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/101truncate-rawdeflate.t b/ext/IO_Compress_Zlib/t/101truncate-rawdeflate.t new file mode 100644 index 0000000000..cc4a2a3e2f --- /dev/null +++ b/ext/IO_Compress_Zlib/t/101truncate-rawdeflate.t @@ -0,0 +1,130 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use Test::More ; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 625 + $extra; + +}; + + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +#sub identify +#{ +# 'IO::Compress::RawDeflate'; +#} +# +#require "truncate.pl" ; +#run(); + +use CompTestUtils; + +my $hello = <<EOM ; +hello world +this is a test +some more stuff on this line +ad finally... +EOM + +my $blocksize = 10 ; + + +foreach my $CompressClass ( 'IO::Compress::RawDeflate') +{ + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($UncompressClass); + + my $compressed ; + ok( my $x = new IO::Compress::RawDeflate \$compressed); + ok $x->write($hello) ; + ok $x->close ; + + + my $cc = $compressed ; + + my $gz ; + ok($gz = new $UncompressClass(\$cc, + -Transparent => 0)) + or diag "$$Error\n"; + my $un; + ok $gz->read($un) > 0 ; + ok $gz->close(); + ok $un eq $hello ; + + for my $trans (0 .. 1) + { + title "Testing $CompressClass, Transparent = $trans"; + + my $info = $gz->getHeaderInfo() ; + my $header_size = $info->{HeaderLength}; + my $trailer_size = $info->{TrailerLength}; + ok 1, "Compressed size is " . length($compressed) ; + ok 1, "Header size is $header_size" ; + ok 1, "Trailer size is $trailer_size" ; + + + title "Compressed Data Truncation"; + foreach my $i (0 .. $blocksize) + { + + my $lex = new LexFile my $name ; + + ok 1, "Length $i" ; + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + my $gz = new $UncompressClass $name, + -BlockSize => $blocksize, + -Transparent => $trans; + if ($trans) { + ok $gz; + ok ! $gz->error() ; + my $buff = ''; + is $gz->read($buff), length $part ; + is $buff, $part ; + ok $gz->eof() ; + $gz->close(); + } + else { + ok !$gz; + } + } + + foreach my $i ($blocksize+1 .. length($compressed)-1) + { + + my $lex = new LexFile my $name ; + + ok 1, "Length $i" ; + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + ok my $gz = new $UncompressClass $name, + -BlockSize => $blocksize, + -Transparent => $trans; + my $un ; + my $status = 1 ; + $status = $gz->read($un) while $status > 0 ; + ok $status < 0 ; + ok $gz->eof() ; + ok $gz->error() ; + $gz->close(); + } + } + +} + diff --git a/ext/IO_Compress_Zlib/t/101truncate-zip.t b/ext/IO_Compress_Zlib/t/101truncate-zip.t new file mode 100644 index 0000000000..719da361ed --- /dev/null +++ b/ext/IO_Compress_Zlib/t/101truncate-zip.t @@ -0,0 +1,38 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +#use Test::More skip_all => "not implemented yet"; +use Test::More ; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 2316 + $extra; + +}; + + + + + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "truncate.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/102tied-deflate.t b/ext/IO_Compress_Zlib/t/102tied-deflate.t new file mode 100644 index 0000000000..8747aee90f --- /dev/null +++ b/ext/IO_Compress_Zlib/t/102tied-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "tied.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/102tied-gzip.t b/ext/IO_Compress_Zlib/t/102tied-gzip.t new file mode 100644 index 0000000000..52a502ecd3 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/102tied-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "tied.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/102tied-rawdeflate.t b/ext/IO_Compress_Zlib/t/102tied-rawdeflate.t new file mode 100644 index 0000000000..f3ba80cfc8 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/102tied-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "tied.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/102tied-zip.t b/ext/IO_Compress_Zlib/t/102tied-zip.t new file mode 100644 index 0000000000..04be98dc6f --- /dev/null +++ b/ext/IO_Compress_Zlib/t/102tied-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "tied.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/103newtied-deflate.t b/ext/IO_Compress_Zlib/t/103newtied-deflate.t new file mode 100644 index 0000000000..42a3d3c2bd --- /dev/null +++ b/ext/IO_Compress_Zlib/t/103newtied-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "newtied.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/103newtied-gzip.t b/ext/IO_Compress_Zlib/t/103newtied-gzip.t new file mode 100644 index 0000000000..7a453fa479 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/103newtied-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "newtied.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/103newtied-rawdeflate.t b/ext/IO_Compress_Zlib/t/103newtied-rawdeflate.t new file mode 100644 index 0000000000..93a5118526 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/103newtied-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "newtied.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/103newtied-zip.t b/ext/IO_Compress_Zlib/t/103newtied-zip.t new file mode 100644 index 0000000000..84b19453b7 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/103newtied-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "newtied.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/104destroy-deflate.t b/ext/IO_Compress_Zlib/t/104destroy-deflate.t new file mode 100644 index 0000000000..37511f7df4 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/104destroy-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "destroy.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/104destroy-gzip.t b/ext/IO_Compress_Zlib/t/104destroy-gzip.t new file mode 100644 index 0000000000..5f686f480c --- /dev/null +++ b/ext/IO_Compress_Zlib/t/104destroy-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "destroy.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/104destroy-rawdeflate.t b/ext/IO_Compress_Zlib/t/104destroy-rawdeflate.t new file mode 100644 index 0000000000..1463000e23 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/104destroy-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "destroy.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/104destroy-zip.t b/ext/IO_Compress_Zlib/t/104destroy-zip.t new file mode 100644 index 0000000000..d071a06d37 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/104destroy-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "destroy.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/105oneshot-deflate.t b/ext/IO_Compress_Zlib/t/105oneshot-deflate.t new file mode 100644 index 0000000000..ab108eaa78 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/105oneshot-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "oneshot.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/105oneshot-gzip-only.t b/ext/IO_Compress_Zlib/t/105oneshot-gzip-only.t new file mode 100644 index 0000000000..0382df8e33 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/105oneshot-gzip-only.t @@ -0,0 +1,134 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; + +BEGIN { + plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" ) + if $] < 5.005 ; + + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 70 + $extra ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + + +} + + +sub gzipGetHeader +{ + my $in = shift; + my $content = shift ; + my %opts = @_ ; + + my $out ; + my $got ; + + ok IO::Compress::Gzip::gzip($in, \$out, %opts), " gzip ok" ; + ok IO::Uncompress::Gunzip::gunzip(\$out, \$got), " gunzip ok" + or diag $GunzipError ; + is $got, $content, " got expected content" ; + + my $gunz = new IO::Uncompress::Gunzip \$out, Strict => 0 + or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; + ok $gunz, " Created IO::Uncompress::Gunzip object"; + my $hdr = $gunz->getHeaderInfo(); + ok $hdr, " got Header info"; + my $uncomp ; + ok $gunz->read($uncomp), " read ok" ; + is $uncomp, $content, " got expected content"; + ok $gunz->close, " closed ok" ; + + return $hdr ; + +} + +{ + title "Check gzip header default NAME & MTIME settings" ; + + my $lex = new LexFile my $file1; + + my $content = "hello "; + my $hdr ; + my $mtime ; + + writeFile($file1, $content); + $mtime = (stat($file1))[9]; + # make sure that the gzip file isn't created in the same + # second as the input file + sleep 3 ; + $hdr = gzipGetHeader($file1, $content); + + is $hdr->{Name}, $file1, " Name is '$file1'"; + is $hdr->{Time}, $mtime, " Time is ok"; + + title "Override Name" ; + + writeFile($file1, $content); + $mtime = (stat($file1))[9]; + sleep 3 ; + $hdr = gzipGetHeader($file1, $content, Name => "abcde"); + + is $hdr->{Name}, "abcde", " Name is 'abcde'" ; + is $hdr->{Time}, $mtime, " Time is ok"; + + title "Override Time" ; + + writeFile($file1, $content); + $hdr = gzipGetHeader($file1, $content, Time => 1234); + + is $hdr->{Name}, $file1, " Name is '$file1'" ; + is $hdr->{Time}, 1234, " Time is 1234"; + + title "Override Name and Time" ; + + writeFile($file1, $content); + $hdr = gzipGetHeader($file1, $content, Time => 4321, Name => "abcde"); + + is $hdr->{Name}, "abcde", " Name is 'abcde'" ; + is $hdr->{Time}, 4321, " Time is 4321"; + + title "Filehandle doesn't have default Name or Time" ; + my $fh = new IO::File "< $file1" + or diag "Cannot open '$file1': $!\n" ; + sleep 3 ; + my $before = time ; + $hdr = gzipGetHeader($fh, $content); + my $after = time ; + + ok ! defined $hdr->{Name}, " Name is undef"; + cmp_ok $hdr->{Time}, '>=', $before, " Time is ok"; + cmp_ok $hdr->{Time}, '<=', $after, " Time is ok"; + + $fh->close; + + title "Buffer doesn't have default Name or Time" ; + my $buffer = $content; + $before = time ; + $hdr = gzipGetHeader(\$buffer, $content); + $after = time ; + + ok ! defined $hdr->{Name}, " Name is undef"; + cmp_ok $hdr->{Time}, '>=', $before, " Time is ok"; + cmp_ok $hdr->{Time}, '<=', $after, " Time is ok"; +} + +# TODO add more error cases + diff --git a/ext/IO_Compress_Zlib/t/105oneshot-gzip.t b/ext/IO_Compress_Zlib/t/105oneshot-gzip.t new file mode 100644 index 0000000000..2aab93e67c --- /dev/null +++ b/ext/IO_Compress_Zlib/t/105oneshot-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "oneshot.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/105oneshot-rawdeflate.t b/ext/IO_Compress_Zlib/t/105oneshot-rawdeflate.t new file mode 100644 index 0000000000..50cb80a3c1 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/105oneshot-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "oneshot.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/105oneshot-zip-only.t b/ext/IO_Compress_Zlib/t/105oneshot-zip-only.t new file mode 100644 index 0000000000..807c9e9d61 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/105oneshot-zip-only.t @@ -0,0 +1,237 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; + +BEGIN { + plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" ) + if $] < 5.005 ; + + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 146 + $extra ; + + #use_ok('IO::Compress::Zip', qw(zip $ZipError :zip_method)) ; + use_ok('IO::Compress::Zip', qw(:all)) ; + use_ok('IO::Uncompress::Unzip', qw(unzip $UnzipError)) ; + + +} + + +sub zipGetHeader +{ + my $in = shift; + my $content = shift ; + my %opts = @_ ; + + my $out ; + my $got ; + + ok zip($in, \$out, %opts), " zip ok" ; + ok unzip(\$out, \$got), " unzip ok" + or diag $UnzipError ; + is $got, $content, " got expected content" ; + + my $gunz = new IO::Uncompress::Unzip \$out, Strict => 0 + or diag "UnzipError is $IO::Uncompress::Unzip::UnzipError" ; + ok $gunz, " Created IO::Uncompress::Unzip object"; + my $hdr = $gunz->getHeaderInfo(); + ok $hdr, " got Header info"; + my $uncomp ; + ok $gunz->read($uncomp), " read ok" ; + is $uncomp, $content, " got expected content"; + ok $gunz->close, " closed ok" ; + + return $hdr ; + +} + +{ + title "Check zip header default NAME & MTIME settings" ; + + my $lex = new LexFile my $file1; + + my $content = "hello "; + my $hdr ; + my $mtime ; + + writeFile($file1, $content); + $mtime = (stat($file1))[9]; + # make sure that the zip file isn't created in the same + # second as the input file + sleep 3 ; + $hdr = zipGetHeader($file1, $content); + + is $hdr->{Name}, $file1, " Name is '$file1'"; + is $hdr->{Time}>>1, $mtime>>1, " Time is ok"; + + title "Override Name" ; + + writeFile($file1, $content); + $mtime = (stat($file1))[9]; + sleep 3 ; + $hdr = zipGetHeader($file1, $content, Name => "abcde"); + + is $hdr->{Name}, "abcde", " Name is 'abcde'" ; + is $hdr->{Time} >> 1, $mtime >> 1, " Time is ok"; + + title "Override Time" ; + + writeFile($file1, $content); + my $useTime = time + 2000 ; + $hdr = zipGetHeader($file1, $content, Time => $useTime); + + is $hdr->{Name}, $file1, " Name is '$file1'" ; + is $hdr->{Time} >> 1 , $useTime >> 1 , " Time is $useTime"; + + title "Override Name and Time" ; + + $useTime = time + 5000 ; + writeFile($file1, $content); + $hdr = zipGetHeader($file1, $content, Time => $useTime, Name => "abcde"); + + is $hdr->{Name}, "abcde", " Name is 'abcde'" ; + is $hdr->{Time} >> 1 , $useTime >> 1 , " Time is $useTime"; + + title "Filehandle doesn't have default Name or Time" ; + my $fh = new IO::File "< $file1" + or diag "Cannot open '$file1': $!\n" ; + sleep 3 ; + my $before = time ; + $hdr = zipGetHeader($fh, $content); + my $after = time ; + + ok ! defined $hdr->{Name}, " Name is undef"; + cmp_ok $hdr->{Time} >> 1, '>=', $before >> 1, " Time is ok"; + cmp_ok $hdr->{Time} >> 1, '<=', $after >> 1, " Time is ok"; + + $fh->close; + + title "Buffer doesn't have default Name or Time" ; + my $buffer = $content; + $before = time ; + $hdr = zipGetHeader(\$buffer, $content); + $after = time ; + + ok ! defined $hdr->{Name}, " Name is undef"; + cmp_ok $hdr->{Time} >> 1, '>=', $before >> 1, " Time is ok"; + cmp_ok $hdr->{Time} >> 1, '<=', $after >> 1, " Time is ok"; +} + +for my $stream (0, 1) +{ + for my $zip64 (0, 1) + { + next if $zip64 && ! $stream; + + for my $method (ZIP_CM_STORE, ZIP_CM_DEFLATE) + { + + title "Stream $stream, Zip64 $zip64, Method $method"; + + my $lex = new LexFile my $file1; + + my $content = "hello "; + #writeFile($file1, $content); + + my $status = zip(\$content => $file1 , + Method => $method, + Stream => $stream, + Zip64 => $zip64); + + ok $status, " zip ok" + or diag $ZipError ; + + my $got ; + if ($stream && $method == ZIP_CM_STORE ) { + #eval ' unzip($file1 => \$got) '; + ok ! unzip($file1 => \$got), " unzip fails"; + like $UnzipError, "/Streamed Stored content not supported/", + " Streamed Stored content not supported"; + next ; + } + + ok unzip($file1 => \$got), " unzip ok" + or diag $UnzipError ; + + is $got, $content, " content ok"; + + my $u = new IO::Uncompress::Unzip $file1 + or diag $ZipError ; + + my $hdr = $u->getHeaderInfo(); + ok $hdr, " got header"; + + is $hdr->{Stream}, $stream, " stream is $stream" ; + is $hdr->{MethodID}, $method, " MethodID is $method" ; + is $hdr->{Zip64}, $zip64, " Zip64 is $zip64" ; + } + } +} + +for my $stream (0, 1) +{ + for my $zip64 (0, 1) + { + next if $zip64 && ! $stream; + for my $method (ZIP_CM_STORE, ZIP_CM_DEFLATE) + { + title "Stream $stream, Zip64 $zip64, Method $method"; + + my $file1; + my $file2; + my $zipfile; + my $lex = new LexFile $file1, $file2, $zipfile; + + my $content1 = "hello "; + writeFile($file1, $content1); + + my $content2 = "goodbye "; + writeFile($file2, $content2); + + my %content = ( $file1 => $content1, + $file2 => $content2, + ); + + ok zip([$file1, $file2] => $zipfile , Method => $method, + Zip64 => $zip64, + Stream => $stream), " zip ok" + or diag $ZipError ; + + for my $file ($file1, $file2) + { + my $got ; + if ($stream && $method == ZIP_CM_STORE ) { + #eval ' unzip($zipfile => \$got) '; + ok ! unzip($zipfile => \$got, Name => $file), " unzip fails"; + like $UnzipError, "/Streamed Stored content not supported/", + " Streamed Stored content not supported"; + next ; + } + + ok unzip($zipfile => \$got, Name => $file), " unzip $file ok" + or diag $UnzipError ; + + is $got, $content{$file}, " content ok"; + } + } + } +} + +# TODO add more error cases + diff --git a/ext/IO_Compress_Zlib/t/105oneshot-zip.t b/ext/IO_Compress_Zlib/t/105oneshot-zip.t new file mode 100644 index 0000000000..e236fc66fa --- /dev/null +++ b/ext/IO_Compress_Zlib/t/105oneshot-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "oneshot.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/106prime-deflate.t b/ext/IO_Compress_Zlib/t/106prime-deflate.t new file mode 100644 index 0000000000..0ef9bd8834 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/106prime-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "prime.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/106prime-gzip.t b/ext/IO_Compress_Zlib/t/106prime-gzip.t new file mode 100644 index 0000000000..b6ab10e6d2 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/106prime-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "prime.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/106prime-rawdeflate.t b/ext/IO_Compress_Zlib/t/106prime-rawdeflate.t new file mode 100644 index 0000000000..4c81f7c605 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/106prime-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "prime.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/106prime-zip.t b/ext/IO_Compress_Zlib/t/106prime-zip.t new file mode 100644 index 0000000000..702c40128a --- /dev/null +++ b/ext/IO_Compress_Zlib/t/106prime-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "prime.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/107multi-deflate.t b/ext/IO_Compress_Zlib/t/107multi-deflate.t new file mode 100644 index 0000000000..397869bc92 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/107multi-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "multi.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/107multi-gzip.t b/ext/IO_Compress_Zlib/t/107multi-gzip.t new file mode 100644 index 0000000000..10922ed0da --- /dev/null +++ b/ext/IO_Compress_Zlib/t/107multi-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "multi.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/107multi-rawdeflate.t b/ext/IO_Compress_Zlib/t/107multi-rawdeflate.t new file mode 100644 index 0000000000..374cb67831 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/107multi-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "multi.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/107multi-zip.t b/ext/IO_Compress_Zlib/t/107multi-zip.t new file mode 100644 index 0000000000..fea653fbf6 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/107multi-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "multi.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/108anyunc-deflate.t b/ext/IO_Compress_Zlib/t/108anyunc-deflate.t new file mode 100644 index 0000000000..ed5e6b5efe --- /dev/null +++ b/ext/IO_Compress_Zlib/t/108anyunc-deflate.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Uncompress::AnyUncompress qw($AnyUncompressError) ; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub getClass +{ + 'AnyUncompress'; +} + + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "any.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/108anyunc-gzip.t b/ext/IO_Compress_Zlib/t/108anyunc-gzip.t new file mode 100644 index 0000000000..bac6a6a9d0 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/108anyunc-gzip.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Uncompress::AnyUncompress qw($AnyUncompressError) ; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub getClass +{ + 'AnyUncompress'; +} + + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "any.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/108anyunc-rawdeflate.t b/ext/IO_Compress_Zlib/t/108anyunc-rawdeflate.t new file mode 100644 index 0000000000..7d85dada9a --- /dev/null +++ b/ext/IO_Compress_Zlib/t/108anyunc-rawdeflate.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Uncompress::AnyUncompress qw($AnyUncompressError) ; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub getClass +{ + 'AnyUncompress'; +} + + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "any.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/108anyunc-transparent.t b/ext/IO_Compress_Zlib/t/108anyunc-transparent.t new file mode 100644 index 0000000000..687b1f5cd2 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/108anyunc-transparent.t @@ -0,0 +1,72 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); + +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 15 + $extra ; + + use_ok('IO::Uncompress::AnyUncompress', qw($AnyUncompressError)) ; + +} + +{ + + my $string = <<EOM; +This is not compressed data +EOM + + my $buffer = $string ; + + for my $file (0, 1) + { + title "AnyUncompress with Non-compressed data (File $file)" ; + + my $lex = new LexFile my $output; + my $input ; + + if ($file) { + writeFile($output, $buffer); + $input = $output; + } + else { + $input = \$buffer; + } + + + my $unc ; + my $keep = $buffer ; + $unc = new IO::Uncompress::AnyUncompress $input, -Transparent => 0 ; + ok ! $unc," no AnyUncompress object when -Transparent => 0" ; + is $buffer, $keep ; + + $buffer = $keep ; + $unc = new IO::Uncompress::AnyUncompress \$buffer, -Transparent => 1 ; + ok $unc, " AnyUncompress object when -Transparent => 1" ; + + my $uncomp ; + ok $unc->read($uncomp) > 0 ; + ok $unc->eof() ; + #ok $unc->type eq $Type; + + is $uncomp, $string ; + } +} + +1; diff --git a/ext/IO_Compress_Zlib/t/108anyunc-zip.t b/ext/IO_Compress_Zlib/t/108anyunc-zip.t new file mode 100644 index 0000000000..72e015a6a1 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/108anyunc-zip.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't/compress'; +use strict; +use warnings; + +use IO::Uncompress::AnyUncompress qw($AnyUncompressError) ; + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub getClass +{ + 'AnyUncompress'; +} + + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "any.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/109merge-deflate.t b/ext/IO_Compress_Zlib/t/109merge-deflate.t new file mode 100644 index 0000000000..a489f354d3 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/109merge-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Deflate qw($DeflateError) ; +use IO::Uncompress::Inflate qw($InflateError) ; + +sub identify +{ + 'IO::Compress::Deflate'; +} + +require "merge.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/109merge-gzip.t b/ext/IO_Compress_Zlib/t/109merge-gzip.t new file mode 100644 index 0000000000..3041a99420 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/109merge-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::Gzip qw($GzipError) ; +use IO::Uncompress::Gunzip qw($GunzipError) ; + +sub identify +{ + 'IO::Compress::Gzip'; +} + +require "merge.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/109merge-rawdeflate.t b/ext/IO_Compress_Zlib/t/109merge-rawdeflate.t new file mode 100644 index 0000000000..2c9663726e --- /dev/null +++ b/ext/IO_Compress_Zlib/t/109merge-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use IO::Compress::RawDeflate qw($RawDeflateError) ; +use IO::Uncompress::RawInflate qw($RawInflateError) ; + +sub identify +{ + 'IO::Compress::RawDeflate'; +} + +require "merge.pl" ; +run(); diff --git a/ext/IO_Compress_Zlib/t/109merge-zip.t b/ext/IO_Compress_Zlib/t/109merge-zip.t new file mode 100644 index 0000000000..74adf09bf9 --- /dev/null +++ b/ext/IO_Compress_Zlib/t/109merge-zip.t @@ -0,0 +1,24 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; + +use Test::More skip_all => "not implemented yet"; + + +use IO::Compress::Zip qw($ZipError) ; +use IO::Uncompress::Unzip qw($UnzipError) ; + +sub identify +{ + 'IO::Compress::Zip'; +} + +require "merge.pl" ; +run(); |