diff options
| author | Paul Marquess <paul.marquess@btinternet.com> | 2006-01-09 20:25:00 +0000 |
|---|---|---|
| committer | Rafael Garcia-Suarez <rgarciasuarez@gmail.com> | 2006-01-10 10:05:26 +0000 |
| commit | 1a6a845317ff5e6bc844195898061e5a9910928d (patch) | |
| tree | 1ce6bb51b3450987f1e08250b928e28495686e0f | |
| parent | 2d2af554da24863760d055834f4984fbca7ec85b (diff) | |
| download | perl-1a6a845317ff5e6bc844195898061e5a9910928d.tar.gz | |
Compress::Zlib becomes zlib agnostic
From: "Paul Marquess" <Paul.Marquess@ntlworld.com>
Message-ID: <002101c6155a$c5886c90$1340100a@myopwv.com>
p4raw-id: //depot/perl@26761
115 files changed, 12829 insertions, 9002 deletions
@@ -154,17 +154,27 @@ ext/Compress/Zlib/examples/gzstream Compress::Zlib ext/Compress/Zlib/fallback/constants.h Compress::Zlib ext/Compress/Zlib/fallback/constants.xs Compress::Zlib ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm Compress::Zlib +ext/Compress/Zlib/lib/CompressPlugin/Deflate.pm Compress::Zlib +ext/Compress/Zlib/lib/CompressPlugin/Identity.pm Compress::Zlib +ext/Compress/Zlib/lib/Compress/Zip/Constants.pm Compress::Zlib ext/Compress/Zlib/lib/Compress/Zlib/Common.pm Compress::Zlib ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm Compress::Zlib ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm Compress::Zlib ext/Compress/Zlib/lib/File/GlobMapper.pm Compress::Zlib +ext/Compress/Zlib/lib/IO/Compress/Base.pm Compress::Zlib ext/Compress/Zlib/lib/IO/Compress/Deflate.pm Compress::Zlib ext/Compress/Zlib/lib/IO/Compress/Gzip.pm Compress::Zlib ext/Compress/Zlib/lib/IO/Compress/RawDeflate.pm Compress::Zlib +ext/Compress/Zlib/lib/IO/Compress/Zip.pm Compress::Zlib ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm Compress::Zlib +ext/Compress/Zlib/lib/IO/Uncompress/AnyUncompress.pm Compress::Zlib +ext/Compress/Zlib/lib/IO/Uncompress/Base.pm Compress::Zlib ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm Compress::Zlib ext/Compress/Zlib/lib/IO/Uncompress/Inflate.pm Compress::Zlib ext/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm Compress::Zlib +ext/Compress/Zlib/lib/IO/Uncompress/Unzip.pm Compress::Zlib +ext/Compress/Zlib/lib/UncompressPlugin/Identity.pm Compress::Zlib +ext/Compress/Zlib/lib/UncompressPlugin/Inflate.pm Compress::Zlib ext/Compress/Zlib/Makefile.PL Compress::Zlib ext/Compress/Zlib/pod/FAQ.pod Compress::Zlib ext/Compress/Zlib/ppport.h Compress::Zlib @@ -172,7 +182,14 @@ ext/Compress/Zlib/README Compress::Zlib ext/Compress/Zlib/t/01version.t Compress::Zlib ext/Compress/Zlib/t/02zlib.t Compress::Zlib ext/Compress/Zlib/t/03zlib-v1.t Compress::Zlib -ext/Compress/Zlib/t/04def.t Compress::Zlib +ext/Compress/Zlib/t/04generic-deflate.t Compress::Zlib +ext/Compress/Zlib/t/04generic-gzip.t Compress::Zlib +ext/Compress/Zlib/t/04generic-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/04generic-zip.t Compress::Zlib +ext/Compress/Zlib/t/04zlib-generic-deflate.t Compress::Zlib +ext/Compress/Zlib/t/04zlib-generic-gzip.t Compress::Zlib +ext/Compress/Zlib/t/04zlib-generic-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/04zlib-generic-zip.t Compress::Zlib ext/Compress/Zlib/t/05examples.t Compress::Zlib ext/Compress/Zlib/t/06gzsetp.t Compress::Zlib ext/Compress/Zlib/t/07bufsize.t Compress::Zlib @@ -180,18 +197,51 @@ ext/Compress/Zlib/t/08encoding.t Compress::Zlib ext/Compress/Zlib/t/09gziphdr.t Compress::Zlib ext/Compress/Zlib/t/10defhdr.t Compress::Zlib ext/Compress/Zlib/t/11truncate.t Compress::Zlib -ext/Compress/Zlib/t/12any.t Compress::Zlib -ext/Compress/Zlib/t/13prime.t Compress::Zlib +ext/Compress/Zlib/t/12any-deflate.t Compress::Zlib +ext/Compress/Zlib/t/12any-gzip.t Compress::Zlib +ext/Compress/Zlib/t/12any-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/12any-transparent.t Compress::Zlib +ext/Compress/Zlib/t/12any-zip.t Compress::Zlib +ext/Compress/Zlib/t/13prime-deflate.t Compress::Zlib +ext/Compress/Zlib/t/13prime-gzip.t Compress::Zlib +ext/Compress/Zlib/t/13prime-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/13prime-zip.t Compress::Zlib ext/Compress/Zlib/t/14gzopen.t Compress::Zlib -ext/Compress/Zlib/t/15multi.t Compress::Zlib -ext/Compress/Zlib/t/16oneshot.t Compress::Zlib +ext/Compress/Zlib/t/15multi-deflate.t Compress::Zlib +ext/Compress/Zlib/t/15multi-gzip.t Compress::Zlib +ext/Compress/Zlib/t/15multi-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/15multi-zip.t Compress::Zlib +ext/Compress/Zlib/t/16oneshot-deflate.t Compress::Zlib +ext/Compress/Zlib/t/16oneshot-gzip-only.t Compress::Zlib +ext/Compress/Zlib/t/16oneshot-gzip.t Compress::Zlib +ext/Compress/Zlib/t/16oneshot-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/16oneshot-zip-only.t Compress::Zlib +ext/Compress/Zlib/t/16oneshot-zip.t Compress::Zlib ext/Compress/Zlib/t/17isize.t Compress::Zlib ext/Compress/Zlib/t/18lvalue.t Compress::Zlib -ext/Compress/Zlib/t/19destroy.t Compress::Zlib -ext/Compress/Zlib/t/20tied.t Compress::Zlib -ext/Compress/Zlib/t/21newtied.t Compress::Zlib -ext/Compress/Zlib/t/22merge.t Compress::Zlib +ext/Compress/Zlib/t/19destroy-deflate.t Compress::Zlib +ext/Compress/Zlib/t/19destroy-gzip.t Compress::Zlib +ext/Compress/Zlib/t/19destroy-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/19destroy-zip.t Compress::Zlib +ext/Compress/Zlib/t/20tied-deflate.t Compress::Zlib +ext/Compress/Zlib/t/20tied-gzip.t Compress::Zlib +ext/Compress/Zlib/t/20tied-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/20tied-zip.t Compress::Zlib +ext/Compress/Zlib/t/21newtied-deflate.t Compress::Zlib +ext/Compress/Zlib/t/21newtied-gzip.t Compress::Zlib +ext/Compress/Zlib/t/21newtied-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/21newtied-zip.t Compress::Zlib +ext/Compress/Zlib/t/22merge-deflate.t Compress::Zlib +ext/Compress/Zlib/t/22merge-gzip.t Compress::Zlib +ext/Compress/Zlib/t/22merge-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/22merge-zip.t Compress::Zlib ext/Compress/Zlib/t/23misc.t Compress::Zlib +ext/Compress/Zlib/t/25anyunc-deflate.t Compress::Zlib +ext/Compress/Zlib/t/25anyunc-gzip.t Compress::Zlib +ext/Compress/Zlib/t/25anyunc-rawdeflate.t Compress::Zlib +ext/Compress/Zlib/t/25anyunc-transparent.t Compress::Zlib +ext/Compress/Zlib/t/25anyunc-zip.t Compress::Zlib +ext/Compress/Zlib/t/99pod.t Compress::Zlib ext/Compress/Zlib/t/globmapper.t Compress::Zlib ext/Compress/Zlib/typemap Compress::Zlib ext/Compress/Zlib/Zlib.pm Compress::Zlib @@ -3007,6 +3057,19 @@ t/lib/1_compile.t See if the various libraries and extensions compile t/lib/common.pl Helper for lib/{warnings,feature}.t t/lib/commonsense.t See if configuration meets basic needs t/lib/compmod.pl Helper for 1_compile.t +t/lib/compress/ZlibTestUtils.pm Compress::Zlib +t/lib/compress/any.pl Compress::Zlib +t/lib/compress/anyunc.pl Compress::Zlib +t/lib/compress/destroy.pl Compress::Zlib +t/lib/compress/generic.pl Compress::Zlib +t/lib/compress/merge.pl Compress::Zlib +t/lib/compress/multi.pl Compress::Zlib +t/lib/compress/newtied.pl Compress::Zlib +t/lib/compress/oneshot.pl Compress::Zlib +t/lib/compress/prime.pl Compress::Zlib +t/lib/compress/tied.pl Compress::Zlib +t/lib/compress/truncate.pl Compress::Zlib +t/lib/compress/zlib-generic.pl Compress::Zlib t/lib/contains_pod.xr Pod-Parser test file t/lib/cygwin.t Builtin cygwin function tests t/lib/Devel/switchd.pm Module for t/run/switchd.t @@ -3140,7 +3203,6 @@ t/lib/warnings/toke Tests for toke.c for warnings.t t/lib/warnings/universal Tests for universal.c for warnings.t t/lib/warnings/utf8 Tests for utf8.c for warnings.t t/lib/warnings/util Tests for util.c for warnings.t -t/lib/ZlibTestUtils.pm Compress::Zlib Todo.micro The Wishlist for microperl toke.c The tokener t/op/64bitint.t See if 64 bit integers work diff --git a/ext/Compress/Zlib/Changes b/ext/Compress/Zlib/Changes index 93ddaeb6ab..1b74408034 100644 --- a/ext/Compress/Zlib/Changes +++ b/ext/Compress/Zlib/Changes @@ -1,6 +1,18 @@ CHANGES ------- + 2.000_07 9 January 2006 + + * Breakout zlib specific code into separate modules. + + * Limited support for reading/writing zip files + + 2.000_06 5 October 2005 + + * Added eof parameter to Compress::Zlib::inflate method. + + * Fixed issue with 64-bit + 2.000_05 4 October 2005 * Renamed IO::* to IO::Compress::* & IO::Uncompress::* diff --git a/ext/Compress/Zlib/Makefile.PL b/ext/Compress/Zlib/Makefile.PL index d804fa18d5..4226634fd8 100755 --- a/ext/Compress/Zlib/Makefile.PL +++ b/ext/Compress/Zlib/Makefile.PL @@ -26,11 +26,14 @@ my $WALL = '' ; my $GZIP_OS_CODE = -1 ; #$WALL = ' -pedantic ' if $Config{'cc'} =~ /gcc/ ; -$WALL = ' -Wall -Wno-comment ' if $Config{'cc'} =~ /gcc/ ; +#$WALL = ' -Wall -Wno-comment ' if $Config{'cc'} =~ /gcc/ ; + +unless($ENV{PERL_CORE}) { + $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV; +} -my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV; # don't ask if MM_USE_DEFAULT is set -- enables perl core building on cygwin -if ($^O =~ /cygwin/i and not ($ENV{PERL_MM_USE_DEFAULT} || $PERL_CORE)) +if ($^O =~ /cygwin/i and not ($ENV{PERL_MM_USE_DEFAULT} or $ENV{PERL_CORE})) { print <<EOM ; @@ -67,26 +70,31 @@ ParseCONFIG() ; my @files = ('Zlib.pm', 't/ZlibTestUtils.pm', glob("t/*.t"), + glob("t/*.pl"), + glob("lib/CompressPlugin/*.pm"), + glob("lib/UncompressPlugin/*.pm"), glob("lib/IO/Compress/*.pm"), glob("lib/IO/Uncompress/*.pm"), glob("lib/Compress/Zlib/*.pm"), glob("lib/Compress/Gzip/*.pm"), glob("lib/File/*.pm"), + glob("bzip2/*.pm"), grep(!/\.bak$/, glob("examples/*"))) ; -UpDowngrade(@files) unless $PERL_CORE; +UpDowngrade(@files) unless $ENV{PERL_CORE}; WriteMakefile( NAME => 'Compress::Zlib', - VERSION_FROM => 'Zlib.pm', + VERSION_FROM => 'Zlib.pm', + #OPTIMIZE => '-g', INC => "-I$ZLIB_INCLUDE" , DEFINE => "$OLD_ZLIB $WALL -DGZIP_OS_CODE=$GZIP_OS_CODE" , - XS => { 'Zlib.xs' => 'Zlib.c' }, - $PERL_CORE + XS => { 'Zlib.xs' => 'Zlib.c'}, + $ENV{PERL_CORE} ? (MAN3PODS => {}) : (PREREQ_PM => { 'Scalar::Util' => 0, $] >= 5.005 && $] < 5.006 ? ('File::BSDGlob' => 0) : () } - ), + ), 'depend' => { 'Makefile' => 'config.in' }, 'clean' => { FILES => '*.c constants.h constants.xs' }, 'dist' => { COMPRESS => 'gzip', @@ -97,11 +105,11 @@ WriteMakefile( ? zlib_files($ZLIB_LIB) : (LIBS => [ "-L$ZLIB_LIB -lz " ]) ), - ($] >= 5.005 + $] >= 5.005 ? (ABSTRACT_FROM => 'Zlib.pm', AUTHOR => 'Paul Marquess <pmqs@cpan.org>') - : () - ), + : (), + ) ; my @names = qw( @@ -175,6 +183,7 @@ if (eval {require ExtUtils::Constant; 1}) { NAMES => \@names, C_FILE => 'constants.h', XS_FILE => 'constants.xs', + ); } else { @@ -193,7 +202,7 @@ sub MY::libscan return undef if $path =~ /(~|\.bak|_bak)$/ || - $path =~ /\..*\.swp$/ || + $path =~ /\..*\.sw(o|p)$/ || $path =~ /\B\.svn\b/; return $path; @@ -237,13 +246,9 @@ longcover: @echo Running test suite with Devel::Cover HARNESS_PERL_SWITCHES=-MDevel::Cover $(MAKE) test COMPRESS_ZLIB_RUN_ALL=1 -test-utf8: - @echo Running test suite with utf-8 enabled - env LC_ALL=en_GB.UTF-8 $(MAKE) test - -test-utf8de: - @echo Running test suite with utf-8 and non-english enabled - env LC_ALL=de_DE.UTF-8 $(MAKE) test +test-unicode: + @echo Running test suite with unicode support enabled + env PERL_UNICODE=63 $(MAKE) test EOM @@ -251,13 +256,13 @@ EOM gcov: @echo Running test suite with gcov and Devel::Cover [needs gcc 3.4?] - #@test "${CC}" = "gcc" || (echo 'gcov' needs gcc, you have ${CC} ; exit 1) rm -f *.o *.gcov *.da *.bbg *.bb *.gcno - $(MAKE) OPTIMIZE=-g DEFINE="-fprofile-arcs -ftest-coverage" - HARNESS_PERL_SWITCHES=-MDevel::Cover $(MAKE) test - #gcov Zlib.xs - #gcov2perl -db cover_db Zlib.xs.gcov - + HARNESS_PERL_SWITCHES=-MDevel::Cover $(MAKE) test \ + OPTIMIZE=-g \ + CCFLAGS=-O0\ -fprofile-arcs\ -ftest-coverage \ + OTHERLDFLAGS=-fprofile-arcs\ -ftest-coverage + gcov Zlib.xs + gcov2perl -db cover_db Zlib.xs.gcov EOM return $postamble; diff --git a/ext/Compress/Zlib/README b/ext/Compress/Zlib/README index efeb32f6d6..ec1aee4e60 100644 --- a/ext/Compress/Zlib/README +++ b/ext/Compress/Zlib/README @@ -1,11 +1,11 @@ Compress::Zlib - Version 2.000_05 + Version 2.000_07 - 4 Oct 2005 + 9 Jan 2006 - Copyright (c) 1995-2005 Paul Marquess. All rights reserved. + Copyright (c) 1995-2006 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. @@ -28,8 +28,8 @@ DESCRIPTION ----------- This module provides a Perl interface to most of the zlib compression -library. For more details see the pod documentation embedded in the -file Zlib.pm. +library. For more details see the pod documentation embedded in the file +Zlib.pm. If you have downloaded this module in the expectation of manipulating the contents of .zip files, you will need to fetch and build the Archive::Zip @@ -131,13 +131,13 @@ before building this module. -------- For option 2, fetch a copy of the zlib source distribution from - http://www.zlib.org and unpack it into the Compress::Zlib source - directory. Assuming you have fetched zlib 1.2.3, it will create a + http://www.zlib.org and unpack it into the Compress::Zlib source directory. + Assuming you have fetched zlib 1.2.3, it will create a directory called zlib-1.2.3. Now set the variables in the file config.in as follows (if the version - you have fetched isn't 1.2.3, change the INCLUDE and LIB variables - appropriately): + you have fetched isn't 1.2.3, change the INCLUDE and LIB + variables appropriately): BUILD_ZLIB = True INCLUDE = ./zlib-1.2.3 @@ -178,34 +178,34 @@ before building this module. Setting the Gzip OS Code ------------------------ -Every gzip stream stores a byte in its header to identify the Operating System -that was used to create the gzip stream. When you build Compress::Zlib it will -attempt to determine the value that is correct for your Operating System. This -will then be used by IO::Gzip as the default value for the OS byte in all gzip -headers it creates. +Every gzip stream stores a byte in its header to identify the Operating +System that was used to create the gzip stream. When you build +Compress::Zlib it will attempt to determine the value that is correct for +your Operating System. This will then be used by IO::Gzip as the default +value for the OS byte in all gzip headers it creates. -The variable GZIP_OS_CODE in the config.in file controls the setting of this -value when building Compress::Zlib. If GZIP_OS_CODE is set to AUTO_DETECT, -Compress::Zlib will attempt to determine the correct value for your Operating -System. +The variable GZIP_OS_CODE in the config.in file controls the setting of +this value when building Compress::Zlib. If GZIP_OS_CODE is set to +AUTO_DETECT, Compress::Zlib will attempt to determine the correct value for +your Operating System. Alternatively, you can override auto-detection of the default OS code and -explicitly set it yourself. Set the GZIP_OS_CODE variable in the config.in file -to be a number between 0 and 255. For example +explicitly set it yourself. Set the GZIP_OS_CODE variable in the config.in +file to be a number between 0 and 255. For example GZIP_OS_CODE = 3 See RFC 1952 for valid OS codes that can be used. -If you are running one of the less popular Operating Systems, it could be that -the default value picked by this module is incorrect or the default value (3) -is used when there is a better value available. When Compress::Zlib cannot -determine what operating system you are running, it will use the default value -3 for the OS code. +If you are running one of the less popular Operating Systems, it could be +that the default value picked by this module is incorrect or the default +value (3) is used when there is a better value available. When +Compress::Zlib cannot determine what operating system you are running, it +will use the default value 3 for the OS code. If you find you have to change this value, because you think the value auto -detected is incorrect, please take a few moments to contact the author of this -module. +detected is incorrect, please take a few moments to contact the author of +this module. TROUBLESHOOTING @@ -327,7 +327,7 @@ 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 these test. This should not be considered a bug +run out of memory during this test. This should not be considered a bug in the Compress::Zlib module. diff --git a/ext/Compress/Zlib/Zlib.pm b/ext/Compress/Zlib/Zlib.pm index 9a3598ba98..34e57e7b62 100644 --- a/ext/Compress/Zlib/Zlib.pm +++ b/ext/Compress/Zlib/Zlib.pm @@ -8,7 +8,7 @@ use Carp ; use IO::Handle ; use Scalar::Util qw(dualvar); -use Compress::Zlib::Common; +use Compress::Zlib::Common ; use Compress::Zlib::ParseParameters; use strict ; @@ -16,7 +16,7 @@ use warnings ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD); -$VERSION = '2.000_06'; +$VERSION = '2.000_07'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -73,6 +73,7 @@ $VERSION = eval $VERSION; Z_VERSION_ERROR ); + sub AUTOLOAD { my($constname); ($constname = $AUTOLOAD) =~ s/.*:://; @@ -181,14 +182,15 @@ sub gzopen($$) if ($writing) { $gz = new IO::Compress::Gzip($file, Minimal => 1, AutoClose => 1, - %defOpts) + %defOpts) or $Compress::Zlib::gzerrno = $IO::Compress::Gzip::GzipError; } else { $gz = new IO::Uncompress::Gunzip($file, - Transparent => 1, - Append => 0, - AutoClose => 1, Strict => 0) + Transparent => 1, + Append => 0, + AutoClose => 1, + Strict => 0) or $Compress::Zlib::gzerrno = $IO::Uncompress::Gunzip::GunzipError; } @@ -313,7 +315,7 @@ sub Compress::Zlib::gzFile::gzsetparams return _set_gzerr(Z_STREAM_ERROR()) if $self->[1] ne 'deflate'; - my $status = *$gz->{Deflate}->deflateParams(-Level => $level, + my $status = *$gz->{Compress}->deflateParams(-Level => $level, -Strategy => $strategy); _save_gzerr($gz); return $status ; @@ -332,17 +334,17 @@ sub Compress::Zlib::Deflate::new my $pkg = shift ; my ($got) = ParseParameters(0, { - 'AppendOutput' => [Parse_boolean, 0], - 'CRC32' => [Parse_boolean, 0], - 'ADLER32' => [Parse_boolean, 0], - 'Bufsize' => [Parse_unsigned, 4096], + 'AppendOutput' => [1, 1, Parse_boolean, 0], + 'CRC32' => [1, 1, Parse_boolean, 0], + 'ADLER32' => [1, 1, Parse_boolean, 0], + 'Bufsize' => [1, 1, Parse_unsigned, 4096], - 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION()], - 'Method' => [Parse_unsigned, Z_DEFLATED()], - 'WindowBits' => [Parse_signed, MAX_WBITS()], - 'MemLevel' => [Parse_unsigned, MAX_MEM_LEVEL()], - 'Strategy' => [Parse_unsigned, Z_DEFAULT_STRATEGY()], - 'Dictionary' => [Parse_any, ""], + 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()], + 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()], + 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()], + 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()], + 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()], + 'Dictionary' => [1, 1, Parse_any, ""], }, @_) ; @@ -371,14 +373,14 @@ sub Compress::Zlib::Inflate::new my $pkg = shift ; my ($got) = ParseParameters(0, { - 'AppendOutput' => [Parse_boolean, 0], - 'CRC32' => [Parse_boolean, 0], - 'ADLER32' => [Parse_boolean, 0], - 'ConsumeInput' => [Parse_boolean, 1], - 'Bufsize' => [Parse_unsigned, 4096], + 'AppendOutput' => [1, 1, Parse_boolean, 0], + 'CRC32' => [1, 1, Parse_boolean, 0], + 'ADLER32' => [1, 1, Parse_boolean, 0], + 'ConsumeInput' => [1, 1, Parse_boolean, 1], + 'Bufsize' => [1, 1, Parse_unsigned, 4096], - 'WindowBits' => [Parse_signed, MAX_WBITS()], - 'Dictionary' => [Parse_any, ""], + 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()], + 'Dictionary' => [1, 1, Parse_any, ""], }, @_) ; @@ -401,12 +403,12 @@ sub Compress::Zlib::InflateScan::new my $pkg = shift ; my ($got) = ParseParameters(0, { - 'CRC32' => [Parse_boolean, 0], - 'ADLER32' => [Parse_boolean, 0], - 'Bufsize' => [Parse_unsigned, 4096], + 'CRC32' => [1, 1, Parse_boolean, 0], + 'ADLER32' => [1, 1, Parse_boolean, 0], + 'Bufsize' => [1, 1, Parse_unsigned, 4096], - 'WindowBits' => [Parse_signed, -MAX_WBITS()], - 'Dictionary' => [Parse_any, ""], + 'WindowBits' => [1, 1, Parse_signed, -MAX_WBITS()], + 'Dictionary' => [1, 1, Parse_any, ""], }, @_) ; @@ -429,16 +431,16 @@ sub Compress::Zlib::inflateScanStream::createDeflateStream my $pkg = shift ; my ($got) = ParseParameters(0, { - 'AppendOutput' => [Parse_boolean, 0], - 'CRC32' => [Parse_boolean, 0], - 'ADLER32' => [Parse_boolean, 0], - 'Bufsize' => [Parse_unsigned, 4096], + 'AppendOutput' => [1, 1, Parse_boolean, 0], + 'CRC32' => [1, 1, Parse_boolean, 0], + 'ADLER32' => [1, 1, Parse_boolean, 0], + 'Bufsize' => [1, 1, Parse_unsigned, 4096], - 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION()], - 'Method' => [Parse_unsigned, Z_DEFLATED()], - 'WindowBits' => [Parse_signed, - MAX_WBITS()], - 'MemLevel' => [Parse_unsigned, MAX_MEM_LEVEL()], - 'Strategy' => [Parse_unsigned, Z_DEFAULT_STRATEGY()], + 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()], + 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()], + 'WindowBits' => [1, 1, Parse_signed, - MAX_WBITS()], + 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()], + 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()], }, @_) ; croak "Compress::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified " . @@ -461,14 +463,30 @@ sub Compress::Zlib::inflateScanStream::createDeflateStream } +sub Compress::Zlib::inflateScanStream::inflate +{ + my $self = shift ; + my $buffer = $_[1]; + my $eof = $_[2]; + + my $status = $self->scan(@_); + + if ($status == Z_OK() && $_[2]) { + my $byte = ' '; + + $status = $self->scan(\$byte, $_[1]) ; + } + + return $status ; +} sub Compress::Zlib::deflateStream::deflateParams { my $self = shift ; my ($got) = ParseParameters(0, { - 'Level' => [Parse_signed, undef], - 'Strategy' => [Parse_unsigned, undef], - 'Bufsize' => [Parse_unsigned, undef], + 'Level' => [1, 1, Parse_signed, undef], + 'Strategy' => [1, 1, Parse_unsigned, undef], + 'Bufsize' => [1, 1, Parse_unsigned, undef], }, @_) ; @@ -545,23 +563,23 @@ sub deflateInit(@) { my ($got) = ParseParameters(0, { - 'Bufsize' => [Parse_unsigned, 4096], - 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION()], - 'Method' => [Parse_unsigned, Z_DEFLATED()], - 'WindowBits' => [Parse_signed, MAX_WBITS()], - 'MemLevel' => [Parse_unsigned, MAX_MEM_LEVEL()], - 'Strategy' => [Parse_unsigned, Z_DEFAULT_STRATEGY()], - 'Dictionary' => [Parse_any, ""], + 'Bufsize' => [1, 1, Parse_unsigned, 4096], + 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()], + 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()], + 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()], + 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()], + 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()], + 'Dictionary' => [1, 1, Parse_any, ""], }, @_ ) ; croak "Compress::Zlib::deflateInit: Bufsize must be >= 1, you specified " . $got->value('Bufsize') unless $got->value('Bufsize') >= 1; - my (%obj) = () ; + my $obj ; my $status = 0 ; - ($obj{def}, $status) = + ($obj, $status) = _deflateInit(0, $got->value('Level'), $got->value('Method'), @@ -571,7 +589,7 @@ sub deflateInit(@) $got->value('Bufsize'), $got->value('Dictionary')) ; - my $x = ($status == Z_OK() ? bless \%obj, "Zlib::OldDeflate" : undef) ; + my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldDeflate" : undef) ; return wantarray ? ($x, $status) : $x ; } @@ -579,9 +597,9 @@ sub inflateInit(@) { my ($got) = ParseParameters(0, { - 'Bufsize' => [Parse_unsigned, 4096], - 'WindowBits' => [Parse_signed, MAX_WBITS()], - 'Dictionary' => [Parse_any, ""], + 'Bufsize' => [1, 1, Parse_unsigned, 4096], + 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()], + 'Dictionary' => [1, 1, Parse_any, ""], }, @_) ; @@ -590,27 +608,29 @@ sub inflateInit(@) unless $got->value('Bufsize') >= 1; my $status = 0 ; - my (%obj) = () ; - ($obj{def}, $status) = _inflateInit(FLAG_CONSUME_INPUT, + my $obj ; + ($obj, $status) = _inflateInit(FLAG_CONSUME_INPUT, $got->value('WindowBits'), $got->value('Bufsize'), $got->value('Dictionary')) ; - my $x = ($status == Z_OK() ? bless \%obj, "Zlib::OldInflate" : undef) ; + my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldInflate" : undef) ; wantarray ? ($x, $status) : $x ; } package Zlib::OldDeflate ; +our (@ISA); +@ISA = qw(Compress::Zlib::deflateStream); + + sub deflate { my $self = shift ; my $output ; - #my (@rest) = @_ ; - - my $status = $self->{def}->deflate($_[0], $output) ; + my $status = $self->SUPER::deflate($_[0], $output) ; wantarray ? ($output, $status) : $output ; } @@ -619,105 +639,24 @@ sub flush my $self = shift ; my $output ; my $flag = shift || Compress::Zlib::Z_FINISH(); - my $status = $self->{def}->flush($output, $flag) ; + my $status = $self->SUPER::flush($output, $flag) ; wantarray ? ($output, $status) : $output ; } -sub deflateParams -{ - my $self = shift ; - $self->{def}->deflateParams(@_) ; -} - -sub msg -{ - my $self = shift ; - $self->{def}->msg() ; -} - -sub total_in -{ - my $self = shift ; - $self->{def}->total_in() ; -} - -sub total_out -{ - my $self = shift ; - $self->{def}->total_out() ; -} - -sub dict_adler -{ - my $self = shift ; - $self->{def}->dict_adler() ; -} - -sub get_Level -{ - my $self = shift ; - $self->{def}->get_Level() ; -} - -sub get_Strategy -{ - my $self = shift ; - $self->{def}->get_Strategy() ; -} - -#sub DispStream -#{ -# my $self = shift ; -# $self->{def}->DispStream($_[0]) ; -#} - package Zlib::OldInflate ; +our (@ISA); +@ISA = qw(Compress::Zlib::inflateStream); + sub inflate { my $self = shift ; my $output ; - my $status = $self->{def}->inflate($_[0], $output) ; + my $status = $self->SUPER::inflate($_[0], $output) ; wantarray ? ($output, $status) : $output ; } -sub inflateSync -{ - my $self = shift ; - $self->{def}->inflateSync($_[0]) ; -} - -sub msg -{ - my $self = shift ; - $self->{def}->msg() ; -} - -sub total_in -{ - my $self = shift ; - $self->{def}->total_in() ; -} - -sub total_out -{ - my $self = shift ; - $self->{def}->total_out() ; -} - -sub dict_adler -{ - my $self = shift ; - $self->{def}->dict_adler() ; -} - -#sub DispStream -#{ -# my $self = shift ; -# $self->{def}->DispStream($_[0]) ; -#} - package Compress::Zlib ; use Compress::Gzip::Constants; @@ -875,7 +814,7 @@ Compress::Zlib - Interface to zlib compression library $d->get_BufSize(); ($i, $status) = new Compress::Zlib::Inflate( [OPT] ) ; - $status = $i->inflate($input, $output) ; + $status = $i->inflate($input, $output [, $eof]) ; $status = $i->inflateSync($input) ; $i->dict_adler() ; $d->crc32() ; @@ -967,7 +906,7 @@ have been made to the C<gzopen> interface: =item 1 -If you want to to open either STDIN or STDOUT with C<gzopen>, you can +If you want to to open either STDIN or STDOUT with C<gzopen>, you can now optionally use the special filename "C<->" as a synonym for C<\*STDIN> and C<\*STDOUT>. @@ -984,8 +923,8 @@ stream that is embedded in a larger file, without having to resort to opening and closing the file multiple times. In C<Compress::Zlib> version 2.x, the C<gzopen> interface has been completely -rewritten to use the L<IO::Compress::Gzip|IO::Compress::Gzip> for writing gzip files and -L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for reading gzip files. +rewritten to use the L<IO::Gzip|IO::Gzip> for writing gzip files and +L<IO::Gunzip|IO::Gunzip> for reading gzip files. =item 3 @@ -997,9 +936,9 @@ Added C<gztell>. =back -A more complete and flexible interface for reading/writing gzip files/buffers -is included with this module. See L<IO::Compress::Gzip|IO::Compress::Gzip> and -L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for more details. +A more complete and flexible interface for reading/writing gzip +files/buffers is included with this module. See L<IO::Gzip|IO::Gzip> and +L<IO::Gunzip|IO::Gunzip> for more details. =over 5 @@ -1007,14 +946,14 @@ L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for more details. =item B<$gz = gzopen($filehandle, $mode)> -This function opens either the I<gzip> file C<$filename> for reading or writing -or attaches to the opened filehandle, C<$filehandle>. It returns an object on -success and C<undef> on failure. +This function opens either the I<gzip> file C<$filename> for reading or +writing or attaches to the opened filehandle, C<$filehandle>. +It returns an object on success and C<undef> on failure. When writing a gzip file this interface will always create the smallest -possible gzip header (exactly 10 bytes). If you want control over the -information stored in the gzip header (like the original filename or a comment) -use L<IO::Compress::Gzip|IO::Compress::Gzip> instead. +possible gzip header (exactly 10 bytes). If you want greater control over +the information stored in the gzip header (like the original filename or a +comment) use L<IO::Gzip|IO::Gzip> instead. The second parameter, C<$mode>, is used to specify whether the file is opened for reading or writing and to optionally specify a compression @@ -1090,8 +1029,6 @@ Returns the uncompressed file offset. =item B<$status = $gz-E<gt>gzseek($offset, $whence) ;> -Sets the file position of the - Provides a sub-set of the C<seek> functionality, with the restriction that it is only legal to seek forward in the compressed file. It is a fatal error to attempt to seek backward. @@ -1261,7 +1198,7 @@ undef. The C<$buffer> parameter can either be a scalar or a scalar reference. -See L<IO::Compress::Gzip|IO::Compress::Gzip> for an alternative way to carry out in-memory gzip +See L<IO::Gzip|IO::Gzip> for an alternative way to carry out in-memory gzip compression. =head2 Compress::Zlib::memGunzip @@ -1276,7 +1213,7 @@ returns undef. The C<$buffer> parameter can either be a scalar or a scalar reference. The contents of the C<$buffer> parameter are destroyed after calling this function. -See L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for an alternative way to carry out in-memory gzip +See L<IO::Gunzip|IO::Gunzip> for an alternative way to carry out in-memory gzip uncompression. =head1 COMPRESS/UNCOMPRESS @@ -1312,7 +1249,7 @@ The source buffer can either be a scalar or a scalar reference. Please note: the two functions defined above are I<not> compatible with the Unix commands of the same name. -See L<IO::Compress::Deflate|IO::Compress::Deflate> and L<IO::Uncompress::Inflate|IO::Uncompress::Inflate> included with +See L<IO::Deflate|IO::Deflate> and L<IO::Inflate|IO::Inflate> included with this distribution for an alternative interface for reading/writing RFC 1950 files/buffers. @@ -1671,8 +1608,12 @@ Here is a list of the valid options: =item B<-WindowBits> -For a definition of the meaning and valid values for C<WindowBits> -refer to the I<zlib> documentation for I<inflateInit2>. +To uncompress an RFC1950 data stream, set C<WindowBits> to a positive number. + +To uncompress an RFC1951 data stream, set C<WindowBits> to C<-MAX_WBITS>. + +For a full definition of the meaning and valid values for C<WindowBits> refer +to the I<zlib> documentation for I<inflateInit2>. Defaults to C<-WindowBits =E<gt>MAX_WBITS>. @@ -1734,7 +1675,7 @@ buffer size. my ($i, $status) = new Compress::Zlib::Inflate( -Bufsize => 300 ) ; -=head2 B< $status = $i-E<gt>inflate($input, $output) > +=head2 B< $status = $i-E<gt>inflate($input, $output [,$eof]) > Inflates the complete contents of C<$input> and writes the uncompressed data to C<$output>. The C<$input> and C<$output> parameters can either be @@ -1763,6 +1704,45 @@ this object, the uncompressed data will be appended to C<$output>. If it is false, C<$output> will be truncated before any uncompressed data is written to it. +The C<$eof> parameter needs a bit of explanation. + +Prior to version 1.2.0, zlib assumed that there was at least one trailing +byte immediately after the compressed data stream when it was carrying out +decompression. This normally isn't a problem because the majority of zlib +applications guarantee that there will be data directly after the +compressed data stream. For example, both gzip (RFC1950) and zip both +define trailing data that follows the compressed data stream. + +The C<$eof> parameter only needs to be used if B<all> of the following +conditions apply + +=over 5 + +=item 1 + +You are either using a copy of zlib that is older than version 1.2.0 or you +want your application code to be able to run with as many different +versions of zlib as possible. + +=item 2 + +You have set the C<WindowBits> parameter to C<-MAX_WBITS> in the constructor +for this object, i.e. you are uncompressing a raw deflated data stream +(RFC1951). + +=item 3 + +There is no data immediately after the compressed data stream. + +=back + +If B<all> of these are the case, then you need to set the C<$eof> parameter to +true on the final call (and only the final call) to C<$i-E<gt>inflate>. + +If you have built this module with zlib >= 1.2.0, the C<$eof> parameter is +ignored. You can still set it if you want, but it won't be used behind the +scenes. + =head2 B<$status = $i-E<gt>inflateSync($input)> This method can be used to attempt to recover good data from a compressed @@ -1899,8 +1879,12 @@ the default) is C<-Method =E<gt>Z_DEFLATED>. =item B<-WindowBits> -For a definition of the meaning and valid values for C<WindowBits> -refer to the I<zlib> documentation for I<deflateInit2>. +To create an RFC1950 data stream, set C<WindowBits> to a positive number. + +To create an RFC1951 data stream, set C<WindowBits> to C<-MAX_WBITS>. + +For a full definition of the meaning and valid values for C<WindowBits> refer +to the I<zlib> documentation for I<deflateInit2>. Defaults to C<-WindowBits =E<gt>MAX_WBITS>. @@ -2065,7 +2049,7 @@ Here is a definition of the interface: =head2 B<($i, $status) = inflateInit()> -Initialises an inflation stream. +Initializes an inflation stream. In a list context it returns the inflation stream, C<$i>, and the I<zlib> status code (C<$status>). In a scalar context it returns the @@ -2093,8 +2077,12 @@ Here is a list of the valid options: =item B<-WindowBits> -For a definition of the meaning and valid values for C<WindowBits> -refer to the I<zlib> documentation for I<inflateInit2>. +To uncompress an RFC1950 data stream, set C<WindowBits> to a positive number. + +To uncompress an RFC1951 data stream, set C<WindowBits> to C<-MAX_WBITS>. + +For a full definition of the meaning and valid values for C<WindowBits> refer +to the I<zlib> documentation for I<inflateInit2>. Defaults to C<-WindowBits =E<gt>MAX_WBITS>. @@ -2247,7 +2235,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 1995-2005 Paul Marquess. All rights reserved. +Copyright (c) 1995-2006 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/Compress/Zlib/Zlib.xs b/ext/Compress/Zlib/Zlib.xs index 8bf75f1a36..b7cd48ad3b 100644 --- a/ext/Compress/Zlib/Zlib.xs +++ b/ext/Compress/Zlib/Zlib.xs @@ -33,6 +33,14 @@ #include <zlib.h> +/* zlib prior to 1.06 doesn't know about z_off_t */ +#ifndef z_off_t +# define z_off_t long +#endif + +#if ! defined(ZLIB_VERNUM) || ZLIB_VERNUM < 0x1200 +# define NEED_DUMMY_BYTE_AT_END +#endif #if defined(ZLIB_VERNUM) && ZLIB_VERNUM >= 0x1210 # define MAGIC_APPEND @@ -56,11 +64,6 @@ #else -/* zlib prior to 1.06 doesn't know about z_off_t */ -#ifndef z_off_t -# define z_off_t long -#endif - # ifndef PERL_VERSION # include "patchlevel.h" # define PERL_REVISION 5 @@ -81,14 +84,9 @@ # define newSVuv newSViv # endif -#endif - -#if PERL_REVISION == 5 && (PERL_VERSION >= 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 4 )) -# define UTF8_AVAILABLE -#endif -#if PERL_REVISION == 5 && (PERL_VERSION < 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 4 )) +# if PERL_REVISION == 5 && (PERL_VERSION < 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 4 )) # ifdef SvPVbyte_force # undef SvPVbyte_force @@ -96,42 +94,57 @@ # define SvPVbyte_force(sv,lp) SvPV_force(sv,lp) -#endif +# endif -#ifndef SvPVbyte_nolen +# ifndef SvPVbyte_nolen # define SvPVbyte_nolen SvPV_nolen -#endif +# endif -#ifndef SvPVbyte +# ifndef SvPVbyte # define SvPVbyte SvPV -#endif +# endif -#ifndef dTHX +# ifndef dTHX # define dTHX -#endif +# endif -#ifndef SvPV_nolen +# ifndef SvPV_nolen -#define sv_2pv_nolen(a) my_sv_2pv_nolen(a) +# define sv_2pv_nolen(a) my_sv_2pv_nolen(a) static char * my_sv_2pv_nolen(register SV *sv) { + dTHX; STRLEN n_a; return sv_2pv(sv, &n_a); } /* SvPV_nolen depends on sv_2pv_nolen */ -#define SvPV_nolen(sv) \ +# define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_nolen(sv)) +# endif + +# ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +# endif + #endif -#ifndef SvGETMAGIC -# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +# ifndef SvPVbyte_nolen +# define SvPVbyte_nolen SvPV_nolen +# endif + +# ifndef SvPVbyte_force +# define SvPVbyte_force(sv,lp) SvPV_force(sv,lp) +# endif + +#if PERL_REVISION == 5 && (PERL_VERSION >= 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 4 )) +# define UTF8_AVAILABLE #endif typedef int DualType ; @@ -167,6 +180,8 @@ typedef struct di_stream { int MemLevel; int Strategy; uLong bytesInflated ; + uLong compressedBytes ; + uLong uncompressedBytes ; #ifdef MAGIC_APPEND #define WINDOW_SIZE 32768U @@ -333,6 +348,7 @@ SetGzErrorNo(error_no) int error_no ; #endif { + dTHX; char * errstr ; SV * gzerror_sv = perl_get_sv(GZERRNO, FALSE) ; @@ -583,6 +599,8 @@ PostInitStream(s, flags, bufsize, windowBits) { s->bufsize = bufsize ; s->bufinc = bufsize ; + s->compressedBytes = + s->uncompressedBytes = s->last_error = 0 ; s->flags = flags ; s->zip_mode = (windowBits < 0) ; @@ -698,49 +716,6 @@ BOOT: SvIOK_on(gzerror_sv) ; } - -int -_readonly_ref(sv) - SV* sv - CODE: - if (SvROK(sv)) - RETVAL = SvREADONLY(SvRV(sv)) ; - else - RETVAL = SvREADONLY(sv) ; - OUTPUT: - RETVAL - -void -_dualvar(num,str) - SV * num - SV * str -PROTOTYPE: $$ -CODE: -{ - STRLEN len; - char *ptr = SvPVbyte(str,len); - ST(0) = sv_newmortal(); - SvUPGRADE(ST(0),SVt_PVNV); - sv_setpvn(ST(0),ptr,len); - if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { - SvNV_set(ST(0), SvNV(num)); - SvNOK_on(ST(0)); - } -#ifdef SVf_IVisUVXXXX - else if (SvUOK(num)) { - SvUVX(ST(0)) = SvUV(num); - SvIOK_on(ST(0)); - SvIsUV_on(ST(0)); - } -#endif - else { - SvIV_set(ST(0), SvIV(num)); - SvIOK_on(ST(0)); - } - XSRETURN(1); -} - - #define Zip_zlib_version() (char*)zlib_version char* Zip_zlib_version() @@ -986,6 +961,7 @@ deflate (s, buf, output) SV * output uInt cur_length = NO_INIT uInt increment = NO_INIT + uInt prefix = NO_INIT int RETVAL = 0; CODE: @@ -998,7 +974,7 @@ deflate (s, buf, output) croak("Wide character in Compress::Zlib::Deflate::deflate input parameter"); #endif s->stream.next_in = (Bytef*)SvPVbyte_nolen(buf) ; - s->stream.avail_in = SvCUR(buf) ; + s->stream.avail_in = SvCUR(buf) ; if (s->flags & FLAG_CRC32) s->crc32 = crc32(s->crc32, s->stream.next_in, s->stream.avail_in) ; @@ -1017,7 +993,7 @@ deflate (s, buf, output) SvCUR_set(output, 0); /* sv_setpvn(output, "", 0); */ } - cur_length = SvCUR(output) ; + prefix = cur_length = SvCUR(output) ; s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length; increment = SvLEN(output) - cur_length; s->stream.avail_out = increment; @@ -1066,6 +1042,9 @@ deflate (s, buf, output) break; } + s->compressedBytes += cur_length + increment - prefix - s->stream.avail_out ; + s->uncompressedBytes += SvCUR(buf) - s->stream.avail_in ; + s->last_error = RETVAL ; if (RETVAL == Z_OK) { SvPOK_only(output); @@ -1097,6 +1076,7 @@ flush(s, output, f=Z_FINISH) int f uInt cur_length = NO_INIT uInt increment = NO_INIT + uInt prefix = NO_INIT CODE: s->stream.avail_in = 0; /* should be zero already anyway */ @@ -1111,7 +1091,7 @@ flush(s, output, f=Z_FINISH) SvCUR_set(output, 0); /* sv_setpvn(output, "", 0); */ } - cur_length = SvCUR(output) ; + prefix = cur_length = SvCUR(output) ; s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length; increment = SvLEN(output) - cur_length; s->stream.avail_out = increment; @@ -1165,6 +1145,8 @@ flush(s, output, f=Z_FINISH) RETVAL = (RETVAL == Z_STREAM_END ? Z_OK : RETVAL) ; s->last_error = RETVAL ; + + s->compressedBytes += cur_length + increment - prefix - s->stream.avail_out ; if (RETVAL == Z_OK) { SvPOK_only(output); @@ -1279,6 +1261,22 @@ adler32(s) RETVAL uLong +compressedBytes(s) + Compress::Zlib::deflateStream s + CODE: + RETVAL = s->compressedBytes; + OUTPUT: + RETVAL + +uLong +uncompressedBytes(s) + Compress::Zlib::deflateStream s + CODE: + RETVAL = s->uncompressedBytes; + OUTPUT: + RETVAL + +uLong total_in(s) Compress::Zlib::deflateStream s CODE: @@ -1340,14 +1338,15 @@ inflateReset(s) RETVAL DualType -inflate (s, buf, output) +inflate (s, buf, output, eof=FALSE) Compress::Zlib::inflateStream s SV * buf SV * output + bool eof uInt cur_length = 0; uInt prefix_length = 0; uInt increment = 0; - STRLEN stmp = NO_INIT + STRLEN stmp = NO_INIT PREINIT: #ifdef UTF8_AVAILABLE bool out_utf8 = FALSE; @@ -1365,7 +1364,7 @@ inflate (s, buf, output) /* initialise the input buffer */ s->stream.next_in = (Bytef*)SvPVbyte_force(buf, stmp) ; - s->stream.avail_in = SvCUR(buf) ; + s->stream.avail_in = SvCUR(buf) ; /* and retrieve the output buffer */ output = deRef_l(output, "inflate") ; @@ -1403,6 +1402,9 @@ inflate (s, buf, output) RETVAL = inflate(&(s->stream), Z_SYNC_FLUSH); + if (RETVAL == Z_STREAM_ERROR || RETVAL == Z_MEM_ERROR || + RETVAL == Z_DATA_ERROR || RETVAL == Z_STREAM_END ) + break ; if (RETVAL == Z_BUF_ERROR) { if (s->stream.avail_out == 0) @@ -1423,12 +1425,35 @@ inflate (s, buf, output) if (RETVAL != Z_OK) break; } - +#ifdef NEED_DUMMY_BYTE_AT_END + if (eof && RETVAL == Z_OK) { + Bytef* nextIn = s->stream.next_in; + uInt availIn = s->stream.avail_in; + s->stream.next_in = (Bytef*) " "; + s->stream.avail_in = 1; + if (s->stream.avail_out == 0) { + /* out of space in the output buffer so make it bigger */ + Sv_Grow(output, SvLEN(output) + s->bufinc) ; + cur_length += increment ; + s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length ; + increment = s->bufinc ; + s->stream.avail_out = increment; + s->bufinc *= 2 ; + } + RETVAL = inflate(&(s->stream), Z_SYNC_FLUSH); + s->stream.next_in = nextIn ; + s->stream.avail_in = availIn ; + } +#endif + s->last_error = RETVAL ; if (RETVAL == Z_OK || RETVAL == Z_STREAM_END || RETVAL == Z_DATA_ERROR) { unsigned in ; s->bytesInflated = cur_length + increment - s->stream.avail_out - prefix_length; + s->uncompressedBytes += s->bytesInflated ; + s->compressedBytes += SvCUR(buf) - s->stream.avail_in ; + SvPOK_only(output); SvCUR_set(output, prefix_length + s->bytesInflated) ; *SvEND(output) = '\0'; @@ -1470,6 +1495,22 @@ inflateCount(s) OUTPUT: RETVAL +uLong +compressedBytes(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = s->compressedBytes; + OUTPUT: + RETVAL + +uLong +uncompressedBytes(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = s->uncompressedBytes; + OUTPUT: + RETVAL + DualType inflateSync (s, buf) @@ -1628,18 +1669,28 @@ DispStream(s, message=NULL) Compress::Zlib::inflateScanStream s char * message +DualType +inflateReset(s) + Compress::Zlib::inflateScanStream s + CODE: + RETVAL = inflateReset(&(s->stream)) ; + if (RETVAL == Z_OK) { + PostInitStream(s, s->flags, s->bufsize, s->WindowBits) ; + } + OUTPUT: + RETVAL + DualType -scan(s, buf, out=NULL) +scan(s, buf, out=NULL, eof=FALSE) Compress::Zlib::inflateScanStream s SV * buf SV * out + bool eof + bool eof_mode = FALSE; int start_len = NO_INIT - STRLEN stmp = NO_INIT - ALIAS: - inflate = 1 + STRLEN stmp = NO_INIT CODE: /* If the input buffer is a reference, dereference it */ - ix = ix ; /* warning suppression */ #ifndef MAGIC_APPEND buf = buf; croak("scan needs zlib 1.2.1 or better"); @@ -1649,10 +1700,9 @@ scan(s, buf, out=NULL) if (DO_UTF8(buf) && !sv_utf8_downgrade(buf, 1)) croak("Wide character in Compress::Zlib::InflateScan::scan input parameter"); #endif - /* initialise the input buffer */ s->stream.next_in = (Bytef*)SvPVbyte_force(buf, stmp) ; - s->stream.avail_in = SvCUR(buf) ; + s->stream.avail_in = SvCUR(buf) ; start_len = s->stream.avail_in ; s->bytesInflated = 0 ; do @@ -1671,8 +1721,7 @@ scan(s, buf, out=NULL) /* inflate and check for errors */ RETVAL = inflate(&(s->stream), Z_BLOCK); - - if (start_len > 1) + if (start_len > 1 && ! eof_mode) s->window_lastByte = *(s->stream.next_in - 1 ) ; if (RETVAL == Z_STREAM_ERROR || RETVAL == Z_MEM_ERROR || @@ -1687,6 +1736,7 @@ scan(s, buf, out=NULL) s->adler32 = adler32(s->adler32, s->window + s->window_have, WINDOW_SIZE - s->window_have - s->stream.avail_out); + s->uncompressedBytes = s->bytesInflated += WINDOW_SIZE - s->window_have - s->stream.avail_out; if (s->stream.avail_out) @@ -1711,6 +1761,7 @@ scan(s, buf, out=NULL) s->last_error = RETVAL ; s->window_lastoff = s->stream.total_in ; + s->compressedBytes += SvCUR(buf) - s->stream.avail_in ; if (RETVAL == Z_STREAM_END) { @@ -1769,6 +1820,22 @@ inflateCount(s) OUTPUT: RETVAL +uLong +compressedBytes(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = s->compressedBytes; + OUTPUT: + RETVAL + +uLong +uncompressedBytes(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = s->uncompressedBytes; + OUTPUT: + RETVAL + uLong getLastBlockOffset(s) diff --git a/ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm b/ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm index 358dfaa8ff..531b3477f4 100644 --- a/ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm +++ b/ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE); -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; @ISA = qw(Exporter); diff --git a/ext/Compress/Zlib/lib/Compress/Zip/Constants.pm b/ext/Compress/Zlib/lib/Compress/Zip/Constants.pm new file mode 100644 index 0000000000..ef82024140 --- /dev/null +++ b/ext/Compress/Zlib/lib/Compress/Zip/Constants.pm @@ -0,0 +1,135 @@ +package Compress::Zip::Constants; + +use strict ; +use warnings; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); + +$VERSION = '1.00'; + +@ISA = qw(Exporter); + +@EXPORT= qw( + + ZIP_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_FEXTRA_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 + + ); + + +# Constants for the Zip Local Header + +use constant ZIP_ID_SIZE => 4 ; +use constant ZIP_LOCAL_ID => 0x02014B50; +use constant ZIP_LOCAL_ID1 => 0x04; +use constant ZIP_LOCAL_ID2 => 0x03; +use constant ZIP_LOCAL_ID3 => 0x4B; +use constant ZIP_LOCAL_ID4 => 0x50; + +use constant ZIP_MIN_HEADER_SIZE => 30 ; +use constant ZIP_TRAILER_SIZE => 0 ; + + +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_MTIME_DEFAULT => 0x00 ; +use constant GZIP_FEXTRA_DEFAULT => 0x00 ; +use constant GZIP_FEXTRA_HEADER_SIZE => 2 ; +use constant GZIP_FEXTRA_MAX_SIZE => 0xFFFF ; +use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => 4 ; +use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ; +use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ; +use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => 0xFFFF ; + +use constant GZIP_FNAME_INVALID_CHAR_RE => qr/[\x00-\x1F\x7F-\x9F]/; +use constant GZIP_FCOMMENT_INVALID_CHAR_RE => qr/[\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 ; +%ZIP_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_FEXTRA_DEFAULT, GZIP_OS_DEFAULT) ; + + +1; diff --git a/ext/Compress/Zlib/lib/Compress/Zlib/Common.pm b/ext/Compress/Zlib/lib/Compress/Zlib/Common.pm index 36d6f648e7..a01ab9be84 100644 --- a/ext/Compress/Zlib/lib/Compress/Zlib/Common.pm +++ b/ext/Compress/Zlib/lib/Compress/Zlib/Common.pm @@ -9,20 +9,36 @@ use Scalar::Util qw(blessed readonly); use File::GlobMapper; require Exporter; -our ($VERSION, @ISA, @EXPORT); +our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS); @ISA = qw(Exporter); -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; -@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput ckInputParam +@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput isaFileGlobString cleanFileGlobString oneTarget setBinModeInput setBinModeOutput - ckOutputParam ckInOutParams + ckInOutParams + createSelfTiedObject + WANT_CODE WANT_EXT WANT_UNDEF WANT_HASH + + STATUS_OK + STATUS_ENDSTREAM + STATUS_ERROR ); +%EXPORT_TAGS = ( Status => [qw( STATUS_OK + STATUS_ENDSTREAM + STATUS_ERROR + )]); + + +use constant STATUS_OK => 0; +use constant STATUS_ENDSTREAM => 1; +use constant STATUS_ERROR => 2; + our ($needBinmode); $needBinmode = ($^O eq 'MSWin32' || ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} ')) @@ -76,7 +92,8 @@ sub cleanFileGlobString use constant WANT_CODE => 1 ; use constant WANT_EXT => 2 ; use constant WANT_UNDEF => 4 ; -use constant WANT_HASH => 8 ; +#use constant WANT_HASH => 8 ; +use constant WANT_HASH => 0 ; sub whatIsInput($;$) { @@ -137,59 +154,15 @@ sub oneTarget return $_[0] =~ /^(code|handle|buffer|filename)$/; } -sub ckInputParam ($$$;$) -{ - my $from = shift ; - my $inType = whatIsInput($_[0], $_[2]); - local $Carp::CarpLevel = 1; - - croak "$from: input parameter not a filename, filehandle, array ref or scalar ref" - if ! $inType ; - - if ($inType eq 'filename' ) - { - croak "$from: input filename is undef or null string" - if ! defined $_[0] || $_[0] eq '' ; - - if ($_[0] ne '-' && ! -e $_[0] ) - { - ${$_[1]} = "input file '$_[0]' does not exist"; - return undef; - } - } - - return 1; -} - -sub ckOutputParam ($$$) -{ - my $from = shift ; - my $outType = whatIsOutput($_[0]); - local $Carp::CarpLevel = 1; - - croak "$from: output parameter not a filename, filehandle or scalar ref" - if ! $outType ; - - croak "$from: output filename is undef or null string" - if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ; - - croak("$from: output buffer is read-only") - if $outType eq 'buffer' && readonly(${ $_[0] }); - - return 1; -} - sub Validator::new { my $class = shift ; my $Class = shift ; - my $type = shift ; my $error_ref = shift ; my $reportClass = shift ; my %data = (Class => $Class, - Type => $type, Error => $error_ref, reportClass => $reportClass, ) ; @@ -206,35 +179,33 @@ sub Validator::new if (! $inType) { - croak "$reportClass: illegal input parameter" ; + $obj->croakError("$reportClass: illegal input parameter") ; #return undef ; } - if ($inType eq 'hash') - { - $obj->{Hash} = 1 ; - $obj->{oneInput} = 1 ; - return $obj->validateHash($_[0]); - } +# if ($inType eq 'hash') +# { +# $obj->{Hash} = 1 ; +# $obj->{oneInput} = 1 ; +# return $obj->validateHash($_[0]); +# } if (! $outType) { - croak "$reportClass: illegal output parameter" ; + $obj->croakError("$reportClass: illegal output parameter") ; #return undef ; } if ($inType ne 'fileglob' && $outType eq 'fileglob') { - ${ $data{Error} } = "Need input fileglob for outout fileglob"; - return undef ; + $obj->croakError("Need input fileglob for outout fileglob"); } - if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' ) - { - ${ $data{Error} } = "input must ne filename or fileglob when output is a hash"; - return undef ; - } +# if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' ) +# { +# $obj->croakError("input must ne filename or fileglob when output is a hash"); +# } if ($inType eq 'fileglob' && $outType eq 'fileglob') { @@ -243,15 +214,14 @@ sub Validator::new my $mapper = new File::GlobMapper($_[0], $_[1]); if ( ! $mapper ) { - ${ $data{Error} } = $File::GlobMapper::Error ; - return undef ; + return $obj->saveErrorString($File::GlobMapper::Error) ; } $data{Pairs} = $mapper->getFileMap(); return $obj; } - croak("$reportClass: input and output $inType are identical") + $obj->croakError("$reportClass: input and output $inType are identical") if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ; if ($inType eq 'fileglob') # && $outType ne 'fileglob' @@ -261,8 +231,8 @@ sub Validator::new if (@inputs == 0) { - # legal or die? - die "legal or die???" ; + # TODO -- legal or die? + die "globmap matched zero file -- legal or die???" ; } elsif (@inputs == 1) { @@ -287,22 +257,39 @@ sub Validator::new } elsif ($inType eq 'array') { + $data{inType} = 'filenames' ; $obj->validateInputArray($_[0]) or return undef ; } - croak("$reportClass: output buffer is read-only") - if $outType eq 'buffer' && Compress::Zlib::_readonly_ref($_[1]); + return $obj->saveErrorString("$reportClass: output buffer is read-only") + if $outType eq 'buffer' && readonly(${ $_[1] }); if ($outType eq 'filename' ) { - croak "$reportClass: output filename is undef or null string" + $obj->croakError("$reportClass: output filename is undef or null string") if ! defined $_[1] || $_[1] eq '' ; } return $obj ; } +sub Validator::saveErrorString +{ + my $self = shift ; + ${ $self->{Error} } = shift ; + return undef; + +} + +sub Validator::croakError +{ + my $self = shift ; + $self->saveErrorString($_[0]); + croak $_[0]; +} + + sub Validator::validateInputFilenames { @@ -310,21 +297,19 @@ sub Validator::validateInputFilenames foreach my $filename (@_) { - croak "$self->{reportClass}: input filename is undef or null string" + $self->croakError("$self->{reportClass}: input filename is undef or null string") if ! defined $filename || $filename eq '' ; next if $filename eq '-'; if (! -e $filename ) { - ${ $self->{Error} } = "input file '$filename' does not exist"; - return undef; + return $self->saveErrorString("input file '$filename' does not exist"); } if (! -r $filename ) { - ${ $self->{Error} } = "cannot open file '$filename': $!"; - return undef; + return $self->saveErrorString("cannot open file '$filename': $!"); } } @@ -335,45 +320,73 @@ sub Validator::validateInputArray { my $self = shift ; + if ( @{ $_[0] } == 0 ) + { + return $self->saveErrorString("empty array reference") ; + } + foreach my $element ( @{ $_[0] } ) { my $inType = whatIsInput($element); if (! $inType) { - ${ $self->{Error} } = "unknown input parameter" ; - return undef ; + $self->croakError("unknown input parameter") ; } + elsif($inType eq 'filename') + { + $self->validateInputFilenames($element) + or return undef ; + } + else + { + $self->croakError("not a filename") ; + } } return 1 ; } -sub Validator::validateHash +#sub Validator::validateHash +#{ +# my $self = shift ; +# my $href = shift ; +# +# while (my($k, $v) = each %$href) +# { +# my $ktype = whatIsInput($k); +# my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ; +# +# if ($ktype ne 'filename') +# { +# return $self->saveErrorString("hash key not filename") ; +# } +# +# my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ; +# if (! $valid{$vtype}) +# { +# return $self->saveErrorString("hash value not ok") ; +# } +# } +# +# return $self ; +#} + +sub createSelfTiedObject { - my $self = shift ; - my $href = shift ; - - while (my($k, $v) = each %$href) - { - my $ktype = whatIsInput($k); - my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ; - - if ($ktype ne 'filename') - { - ${ $self->{Error} } = "hash key not filename" ; - return undef ; - } + my $class = shift || (caller)[0] ; + my $error_ref = shift ; - my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ; - if (! $valid{$vtype}) - { - ${ $self->{Error} } = "hash value not ok" ; - return undef ; - } - } + my $obj = bless Symbol::gensym(), ref($class) || $class; + tie *$obj, $obj if $] >= 5.005; + *$obj->{Closed} = 1 ; + $$error_ref = ''; + *$obj->{Error} = $error_ref ; + my $errno = 0 ; + *$obj->{ErrorNo} = \$errno ; - return $self ; + return $obj; } + 1; diff --git a/ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm b/ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm index 69befce53d..540f892982 100644 --- a/ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm +++ b/ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT); -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; @ISA = qw(Exporter); diff --git a/ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm b/ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm index d89ec6764e..71fb45b412 100644 --- a/ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm +++ b/ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm @@ -7,7 +7,7 @@ use Carp; require Exporter; our ($VERSION, @ISA, @EXPORT); -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; @ISA = qw(Exporter); use constant Parse_any => 0x01; @@ -23,6 +23,8 @@ use constant OFF_PARSED => 0 ; use constant OFF_TYPE => 1 ; use constant OFF_DEFAULT => 2 ; use constant OFF_FIXED => 3 ; +use constant OFF_FIRST_ONLY => 4 ; +use constant OFF_STICKY => 5 ; push @EXPORT, qw( ParseParameters Parse_any Parse_unsigned Parse_signed @@ -46,6 +48,7 @@ sub ParseParameters sub new { my $class = shift ; + my $obj = { Error => '', Got => {}, } ; @@ -76,6 +79,9 @@ sub parse my $default = shift ; + my $got = $self->{Got} ; + my $firstTime = keys %{ $got } == 0 ; + my (@Bad) ; my @entered = () ; @@ -106,14 +112,23 @@ sub parse } - my %got = () ; while (my ($key, $v) = each %$default) { - my ($type, $value) = @$v ; + croak "need 4 params [@$v]" + if @$v != 4 ; + + my ($first_only, $sticky, $type, $value) = @$v ; my $x ; $self->_checkType($key, \$value, $type, 0, \$x) or return undef ; - $got{lc $key} = [0, $type, $value, $x] ; + + $key = lc $key; + + if ($firstTime || ! $sticky) { + $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ; + } + + $got->{$key}[OFF_PARSED] = 0 ; } for my $i (0.. @entered / 2 - 1) { @@ -124,16 +139,18 @@ sub parse #print defined $$value ? "[$$value]\n" : "[undef]\n"; $key =~ s/^-// ; + my $canonkey = lc $key; - if ($got{lc $key}) + if ($got->{$canonkey} && ($firstTime || + ! $got->{$canonkey}[OFF_FIRST_ONLY] )) { - my $type = $got{lc $key}[OFF_TYPE] ; + my $type = $got->{$canonkey}[OFF_TYPE] ; my $s ; $self->_checkType($key, $value, $type, 1, \$s) or return undef ; #$value = $$value unless $type & Parse_store_ref ; $value = $$value ; - $got{lc $key} = [1, $type, $value, $s] ; + $got->{$canonkey} = [1, $type, $value, $s] ; } else { push (@Bad, $key) } @@ -144,8 +161,6 @@ sub parse return $self->setError("unknown key value(s) @Bad") ; } - $self->{Got} = { %got } ; - return 1; } @@ -179,7 +194,7 @@ sub _checkType } elsif ($type & Parse_unsigned) { - return $self->setError("Parameter '$key' must be an unsigned int, got undef") + return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'") if $validate && ! defined $value ; return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") if $validate && $value !~ /^\d+$/; @@ -189,7 +204,7 @@ sub _checkType } elsif ($type & Parse_signed) { - return $self->setError("Parameter '$key' must be a signed int, got undef") + return $self->setError("Parameter '$key' must be a signed int, got 'undef'") if $validate && ! defined $value ; return $self->setError("Parameter '$key' must be a signed int, got '$value'") if $validate && $value !~ /^-?\d+$/; @@ -199,6 +214,8 @@ sub _checkType } elsif ($type & Parse_boolean) { + return $self->setError("Parameter '$key' must be an int, got '$value'") + if $validate && defined $value && $value !~ /^\d*$/; $$output = defined $value ? $value != 0 : 0 ; return 1; } @@ -258,5 +275,21 @@ sub wantValue } +sub clone +{ + my $self = shift ; + my $obj = { }; + my %got ; + + while (my ($k, $v) = each %{ $self->{Got} }) { + $got{$k} = [ @$v ]; + } + + $obj->{Error} = $self->{Error}; + $obj->{Got} = \%got ; + + return bless $obj ; +} + 1; diff --git a/ext/Compress/Zlib/lib/CompressPlugin/Deflate.pm b/ext/Compress/Zlib/lib/CompressPlugin/Deflate.pm new file mode 100644 index 0000000000..28ca794933 --- /dev/null +++ b/ext/Compress/Zlib/lib/CompressPlugin/Deflate.pm @@ -0,0 +1,164 @@ +package CompressPlugin::Deflate ; + +use strict; +use warnings; + +use Compress::Zlib::Common qw(:Status); + +use Compress::Zlib qw(Z_OK Z_FINISH MAX_WBITS) ; +our ($VERSION); + +$VERSION = '2.000_05'; + +sub mkCompObject +{ + my $crc32 = shift ; + my $adler32 = shift ; + my $level = shift ; + my $strategy = shift ; + + my ($def, $status) = new Compress::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, + 'CompSize' => 0, + 'UnCompSize' => 0, + '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); +} + +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/Compress/Zlib/lib/CompressPlugin/Identity.pm b/ext/Compress/Zlib/lib/CompressPlugin/Identity.pm new file mode 100644 index 0000000000..db90e97622 --- /dev/null +++ b/ext/Compress/Zlib/lib/CompressPlugin/Identity.pm @@ -0,0 +1,121 @@ +package CompressPlugin::Identity ; + +use strict; +use warnings; + +use Compress::Zlib::Common qw(:Status); +use Compress::Zlib () ; +our ($VERSION); + +$VERSION = '2.000_05'; + +sub mkCompObject +{ + my $crc32 = shift ; + my $adler32 = shift ; + my $level = shift ; + my $strategy = shift ; + + return bless { + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + 'ErrorNo' => 0, + 'wantCRC32' => $crc32, + 'CRC32' => Compress::Zlib::crc32(''), + 'wantADLER32'=> $adler32, + 'ADLER32' => Compress::Zlib::adler32(''), + } ; +} + +sub compr +{ + my $self = shift ; + + if (defined ${ $_[0] } && length ${ $_[0] }) { + $self->{CompSize} += length ${ $_[0] } ; + $self->{UnCompSize} = $self->{CompSize} ; + + $self->{CRC32} = Compress::Zlib::crc32($_[0], $self->{CRC32}) + if $self->{wantCRC32}; + + $self->{ADLER32} = Compress::Zlib::adler32($_[0], $self->{ADLER32}) + if $self->{wantADLER32}; + + ${ $_[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 ; + + 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} ; +} + +sub crc32 +{ + my $self = shift ; + return $self->{CRC32}; +} + +sub adler32 +{ + my $self = shift ; + return $self->{ADLER32}; +} + + + +1; + + +__END__ + diff --git a/ext/Compress/Zlib/lib/File/GlobMapper.pm b/ext/Compress/Zlib/lib/File/GlobMapper.pm index b8542264cb..9e7c217cbd 100644 --- a/ext/Compress/Zlib/lib/File/GlobMapper.pm +++ b/ext/Compress/Zlib/lib/File/GlobMapper.pm @@ -12,14 +12,14 @@ BEGIN { require File::BSDGlob; import File::BSDGlob qw(:glob) ; $CSH_GLOB = File::BSDGlob::GLOB_CSH() ; - *globber = \&File::BSDGlob::glob; + *globber = \&File::BSDGlob::csh_glob; } else { require File::Glob; import File::Glob qw(:glob) ; $CSH_GLOB = File::Glob::GLOB_CSH() ; #*globber = \&File::Glob::bsd_glob; - *globber = \&File::Glob::glob; + *globber = \&File::Glob::csh_glob; } } @@ -424,7 +424,7 @@ useful include, file renaming, file copying and file compression. To help explain what C<File::GlobMapper> does, consider what code you would write if you wanted to rename all files in the current directory that ended in C<.tar.gz> to C<.tgz>. So say these files are in the -current directoty +current directory alpha.tar.gz beta.tar.gz @@ -474,11 +474,11 @@ Behind the scenes the C<globmap> function does a combination of a file glob to match existing filenames followed by a substitute to create the new filenames. -Notice how both parameters to C<globmap> are strings that are delimired by <>. +Notice how both parameters to C<globmap> are strings that are delimited by <>. This is done to make them look more like file globs - it is just syntactic sugar, but it can be handy when you want the strings to be visually distinctive. The enclosing <> are optional, so you don't have to use them - in -fact the first thing globmap will do is remove these delimeters if they are +fact the first thing globmap will do is remove these delimiters if they are present. The first parameter to C<globmap>, C<*.tar.gz>, is an I<Input File Glob>. @@ -528,7 +528,7 @@ derived from the I<from> filename. C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to solve all filename mapping operations. Under the hood C<File::Glob> (or for -older verions of Perl, C<File::BSDGlob>) is used to match the files, so you +older versions of Perl, C<File::BSDGlob>) is used to match the files, so you will never have the flexibility of full Perl regular expression. =head2 Input File Glob @@ -624,7 +624,7 @@ Output FileGlobs take the =item "*" -The "*" chanacter will be replaced with the complete input filename. +The "*" character will be replaced with the complete input filename. =item #1 @@ -668,7 +668,7 @@ Here is an example that renames all c files to cpp. =head2 A few example globmaps -Below are a few examles of globmaps +Below are a few examples of globmaps To copy all your .c file to a backup directory diff --git a/ext/Compress/Zlib/lib/IO/Compress/Base.pm b/ext/Compress/Zlib/lib/IO/Compress/Base.pm new file mode 100644 index 0000000000..e084612ec3 --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Compress/Base.pm @@ -0,0 +1,917 @@ + +package IO::Compress::Base ; + +require 5.004 ; + +use strict ; +use warnings; + +use Compress::Zlib::Common; +use Compress::Zlib::ParseParameters; + +use IO::File ; +use Scalar::Util qw(blessed readonly); + +#use File::Glob; +#require Exporter ; +use Carp ; +use Symbol; +use bytes; + +our (@ISA, $VERSION, $got_encode); +@ISA = qw(Exporter IO::File); + +$VERSION = '2.000_05'; + +#Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16. + +#$got_encode = 0; +#eval +#{ +# require Encode; +# Encode->import('encode', 'find_encoding'); +#}; +# +#$got_encode = 1 unless $@; + +sub saveStatus +{ + my $self = shift ; + ${ *$self->{ErrorNo} } = shift() + 0 ; + ${ *$self->{Error} } = '' ; + + return ${ *$self->{ErrorNo} } ; +} + + +sub saveErrorString +{ + my $self = shift ; + my $retval = shift ; + ${ *$self->{Error} } = shift ; + ${ *$self->{ErrorNo} } = shift() + 0 if @_ ; + + return $retval; +} + +sub croakError +{ + my $self = shift ; + $self->saveErrorString(0, $_[0]); + croak $_[0]; +} + +sub closeError +{ + my $self = shift ; + my $retval = shift ; + + my $errno = *$self->{ErrorNo}; + my $error = ${ *$self->{Error} }; + + $self->close(); + + *$self->{ErrorNo} = $errno ; + ${ *$self->{Error} } = $error ; + + return $retval; +} + + + +sub error +{ + my $self = shift ; + return ${ *$self->{Error} } ; +} + +sub errorNo +{ + my $self = shift ; + return ${ *$self->{ErrorNo} } ; +} + + +sub writeAt +{ + my $self = shift ; + my $offset = shift; + my $data = shift; + + if (defined *$self->{FH}) { + my $here = tell(*$self->{FH}); + return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) + if $here < 0 ; + seek(*$self->{FH}, $offset, SEEK_SET) + or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; + defined *$self->{FH}->write($data, length $data) + or return $self->saveErrorString(undef, $!, $!) ; + seek(*$self->{FH}, $here, SEEK_SET) + or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; + } + else { + substr(${ *$self->{Buffer} }, $offset, length($data)) = $data ; + } + + return 1; +} + +sub getOneShotParams +{ + return ( 'MultiStream' => [1, 1, Parse_boolean, 1], + ); +} + +sub checkParams +{ + my $self = shift ; + my $class = shift ; + + my $got = shift || Compress::Zlib::ParseParameters::new(); + + $got->parse( + { + # Generic Parameters + 'AutoClose' => [1, 1, Parse_boolean, 0], + #'Encoding' => [1, 1, Parse_any, undef], + 'Strict' => [0, 1, Parse_boolean, 1], + 'Append' => [1, 1, Parse_boolean, 0], + 'BinModeIn' => [1, 1, Parse_boolean, 0], + + $self->getExtraParams(), + *$self->{OneShot} ? $self->getOneShotParams() + : (), + }, + @_) or $self->croakError("${class}: $got->{Error}") ; + + return $got ; +} + +sub _create +{ + my $obj = shift; + my $got = shift; + + *$obj->{Closed} = 1 ; + + my $class = ref $obj; + $obj->croakError("$class: Missing Output parameter") + if ! @_ && ! $got ; + + my $outValue = shift ; + my $oneShot = 1 ; + + if (! $got) + { + $oneShot = 0 ; + $got = $obj->checkParams($class, undef, @_) + or return undef ; + } + + my $lax = ! $got->value('Strict') ; + + my $outType = whatIsOutput($outValue); + + $obj->ckOutputParam($class, $outValue) + or return undef ; + + if ($outType eq 'buffer') { + *$obj->{Buffer} = $outValue; + } + else { + my $buff = "" ; + *$obj->{Buffer} = \$buff ; + } + + # Merge implies Append + my $merge = $got->value('Merge') ; + my $appendOutput = $got->value('Append') || $merge ; + + if ($merge) + { + # Switch off Merge mode if output file/buffer is empty/doesn't exist + if (($outType eq 'buffer' && length $$outValue == 0 ) || + ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) ) + { $merge = 0 } + } + + # If output is a file, check that it is writable + if ($outType eq 'filename' && -e $outValue && ! -w _) + { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) } + + elsif ($outType eq 'handle' && ! -w $outValue) + { return $obj->saveErrorString(undef, "Output filehandle is not writable" ) } + + +# TODO - encoding +# if ($got->parsed('Encoding')) { +# $obj->croakError("$class: Encode module needed to use -Encoding") +# if ! $got_encode; +# +# my $want_encoding = $got->value('Encoding'); +# my $encoding = find_encoding($want_encoding); +# +# $obj->croakError("$class: Encoding '$want_encoding' is not available") +# if ! $encoding; +# +# *$obj->{Encoding} = $encoding; +# } + + $obj->ckParams($got) + or $obj->croakError("${class}: " . $obj->error()); + + + $obj->saveStatus(STATUS_OK) ; + + my $status ; + if (! $merge) + { + *$obj->{Compress} = $obj->mkComp($class, $got) + or return undef; + + *$obj->{BytesWritten} = 0 ; + *$obj->{UnCompSize_32bit} = 0 ; + + *$obj->{Header} = $obj->mkHeader($got) ; + + if ( $outType eq 'buffer') { + ${ *$obj->{Buffer} } = '' + unless $appendOutput ; + ${ *$obj->{Buffer} } .= *$obj->{Header}; + } + else { + if ($outType eq 'handle') { + *$obj->{FH} = $outValue ; + setBinModeOutput(*$obj->{FH}) ; + $outValue->flush() ; + *$obj->{Handle} = 1 ; + if ($appendOutput) + { + seek(*$obj->{FH}, 0, SEEK_END) + or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; + + } + } + elsif ($outType eq 'filename') { + my $mode = '>' ; + $mode = '>>' + if $appendOutput; + *$obj->{FH} = new IO::File "$mode $outValue" + or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ; + *$obj->{StdIO} = ($outValue eq '-'); + setBinModeOutput(*$obj->{FH}) ; + } + + + if (length *$obj->{Header}) { + defined *$obj->{FH}->write(*$obj->{Header}, length(*$obj->{Header})) + or return $obj->saveErrorString(undef, $!, $!) ; + } + } + } + else + { + *$obj->{Compress} = $obj->createMerge($outValue, $outType) + or return undef; + } + + *$obj->{Closed} = 0 ; + *$obj->{AutoClose} = $got->value('AutoClose') ; + *$obj->{Output} = $outValue; + *$obj->{ClassName} = $class; + *$obj->{Got} = $got; + *$obj->{OneShot} = 0 ; + + return $obj ; +} + +sub ckOutputParam +{ + my $self = shift ; + my $from = shift ; + my $outType = whatIsOutput($_[0]); + + $self->croakError("$from: output parameter not a filename, filehandle or scalar ref") + if ! $outType ; + + $self->croakError("$from: output filename is undef or null string") + if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ; + + $self->croakError("$from: output buffer is read-only") + if $outType eq 'buffer' && readonly(${ $_[0] }); + + return 1; +} + + +sub _def +{ + my $obj = shift ; + + my $class= (caller)[0] ; + my $name = (caller(1))[3] ; + + $obj->croakError("$name: expected at least 1 parameters\n") + unless @_ >= 1 ; + + my $input = shift ; + my $haveOut = @_ ; + my $output = shift ; + + my $x = new Validator($class, *$obj->{Error}, $name, $input, $output) + or return undef ; + + push @_, $output if $haveOut && $x->{Hash}; + + *$obj->{OneShot} = 1 ; + + my $got = $obj->checkParams($name, undef, @_) + or return undef ; + + $x->{Got} = $got ; + +# if ($x->{Hash}) +# { +# while (my($k, $v) = each %$input) +# { +# $v = \$input->{$k} +# unless defined $v ; +# +# $obj->_singleTarget($x, 1, $k, $v, @_) +# or return undef ; +# } +# +# return keys %$input ; +# } + + if ($x->{GlobMap}) + { + $x->{oneInput} = 1 ; + foreach my $pair (@{ $x->{Pairs} }) + { + my ($from, $to) = @$pair ; + $obj->_singleTarget($x, 1, $from, $to, @_) + or return undef ; + } + + return scalar @{ $x->{Pairs} } ; + } + + if (! $x->{oneOutput} ) + { + my $inFile = ($x->{inType} eq 'filenames' + || $x->{inType} eq 'filename'); + + $x->{inType} = $inFile ? 'filename' : 'buffer'; + + foreach my $in ($x->{oneInput} ? $input : @$input) + { + my $out ; + $x->{oneInput} = 1 ; + + $obj->_singleTarget($x, $inFile, $in, \$out, @_) + or return undef ; + + push @$output, \$out ; + #if ($x->{outType} eq 'array') + # { push @$output, \$out } + #else + # { $output->{$in} = \$out } + } + + return 1 ; + } + + # finally the 1 to 1 and n to 1 + return $obj->_singleTarget($x, 1, $input, $output, @_); + + croak "should not be here" ; +} + +sub _singleTarget +{ + my $obj = shift ; + my $x = shift ; + my $inputIsFilename = shift; + my $input = shift; + + if ($x->{oneInput}) + { + $obj->getFileInfo($x->{Got}, $input) + if isaFilename($input) and $inputIsFilename ; + + my $z = $obj->_create($x->{Got}, @_) + or return undef ; + + + defined $z->_wr2($input, $inputIsFilename) + or return $z->closeError(undef) ; + + return $z->close() ; + } + else + { + my $afterFirst = 0 ; + my $inputIsFilename = ($x->{inType} ne 'array'); + my $keep = $x->{Got}->clone(); + + #for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) + for my $element ( @$input) + { + my $isFilename = isaFilename($element); + + if ( $afterFirst ++ ) + { + defined addInterStream($obj, $element, $isFilename) + or return $obj->closeError(undef) ; + } + else + { + $obj->getFileInfo($x->{Got}, $element) + if $isFilename; + + $obj->_create($x->{Got}, @_) + or return undef ; + } + + defined $obj->_wr2($element, $isFilename) + or return $obj->closeError(undef) ; + + *$obj->{Got} = $keep->clone(); + } + return $obj->close() ; + } + +} + +sub _wr2 +{ + my $self = shift ; + + my $source = shift ; + my $inputIsFilename = shift; + + my $input = $source ; + if (! $inputIsFilename) + { + $input = \$source + if ! ref $source; + } + + if ( ref $input && ref $input eq 'SCALAR' ) + { + return $self->syswrite($input, @_) ; + } + + if ( ! ref $input || isaFilehandle($input)) + { + my $isFilehandle = isaFilehandle($input) ; + + my $fh = $input ; + + if ( ! $isFilehandle ) + { + $fh = new IO::File "<$input" + or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ; + } + binmode $fh if *$self->{Got}->valueOrDefault('BinModeIn') ; + + my $status ; + my $buff ; + my $count = 0 ; + while (($status = read($fh, $buff, 4096)) > 0) { + $count += length $buff; + defined $self->syswrite($buff, @_) + or return undef ; + } + + return $self->saveErrorString(undef, $!, $!) + if $status < 0 ; + + if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-') + { + $fh->close() + or return undef ; + } + + return $count ; + } + + croak "Should not be here"; + return undef; +} + +sub addInterStream +{ + my $self = shift ; + my $input = shift ; + my $inputIsFilename = shift ; + + if (*$self->{Got}->value('MultiStream')) + { + $self->getFileInfo(*$self->{Got}, $input) + #if isaFilename($input) and $inputIsFilename ; + if isaFilename($input) ; + + # TODO -- newStream needs to allow gzip/zip header to be modified + return $self->newStream(); + } + elsif (*$self->{Got}->value('AutoFlush')) + { + #return $self->flush(Z_FULL_FLUSH); + } + + return 1 ; +} + +sub TIEHANDLE +{ + return $_[0] if ref($_[0]); + die "OOPS\n" ; +} + +sub UNTIE +{ + my $self = shift ; +} + +sub DESTROY +{ + my $self = shift ; + $self->close() ; + + # TODO - memory leak with 5.8.0 - this isn't called until + # global destruction + # + %{ *$self } = () ; + undef $self ; +} + + + +sub syswrite +{ + my $self = shift ; + + my $buffer ; + if (ref $_[0] ) { + $self->croakError( *$self->{ClassName} . "::write: not a scalar reference" ) + unless ref $_[0] eq 'SCALAR' ; + $buffer = $_[0] ; + } + else { + $buffer = \$_[0] ; + } + + + if (@_ > 1) { + my $slen = defined $$buffer ? length($$buffer) : 0; + my $len = $slen; + my $offset = 0; + $len = $_[1] if $_[1] < $len; + + if (@_ > 2) { + $offset = $_[2] || 0; + $self->croakError(*$self->{ClassName} . "::write: offset outside string") + if $offset > $slen; + if ($offset < 0) { + $offset += $slen; + $self->croakError( *$self->{ClassName} . "::write: offset outside string") if $offset < 0; + } + my $rem = $slen - $offset; + $len = $rem if $rem < $len; + } + + $buffer = \substr($$buffer, $offset, $len) ; + } + + return 0 if ! defined $$buffer || length $$buffer == 0 ; + + my $buffer_length = defined $$buffer ? length($$buffer) : 0 ; + *$self->{BytesWritten} += $buffer_length ; + my $rest = 0xFFFFFFFF - *$self->{UnCompSize_32bit} ; + if ($buffer_length > $rest) { + *$self->{UnCompSize_32bit} = $buffer_length - $rest - 1; + } + else { + *$self->{UnCompSize_32bit} += $buffer_length ; + } + +# if (*$self->{Encoding}) { +# $$buffer = *$self->{Encoding}->encode($$buffer); +# } + + #my $length = length $$buffer; + my $status = *$self->{Compress}->compr($buffer, *$self->{Buffer}) ; + + return $self->saveErrorString(undef, *$self->{Compress}{Error}, + *$self->{Compress}{ErrorNo}) + if $status == STATUS_ERROR; + + + + if ( defined *$self->{FH} and length ${ *$self->{Buffer} }) { + defined *$self->{FH}->write( ${ *$self->{Buffer} }, length ${ *$self->{Buffer} } ) + or return $self->saveErrorString(undef, $!, $!); + ${ *$self->{Buffer} } = '' ; + } + + return $buffer_length; +} + +sub print +{ + my $self = shift; + + #if (ref $self) { + # $self = *$self{GLOB} ; + #} + + if (defined $\) { + if (defined $,) { + defined $self->syswrite(join($,, @_) . $\); + } else { + defined $self->syswrite(join("", @_) . $\); + } + } else { + if (defined $,) { + defined $self->syswrite(join($,, @_)); + } else { + defined $self->syswrite(join("", @_)); + } + } +} + +sub printf +{ + my $self = shift; + my $fmt = shift; + defined $self->syswrite(sprintf($fmt, @_)); +} + + + +sub flush +{ + my $self = shift ; + my $opt = shift ; + + my $status = *$self->{Compress}->flush(*$self->{Buffer}, $opt) ; + return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) + if $status == STATUS_ERROR; + + if ( defined *$self->{FH} ) { + *$self->{FH}->clearerr(); + defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} }) + or return $self->saveErrorString(0, $!, $!); + ${ *$self->{Buffer} } = '' ; + } + + return 1; +} + +sub newStream +{ + my $self = shift ; + + $self->_writeTrailer() + or return 0 ; + + my $got = $self->checkParams('newStream', *$self->{Got}, @_) + or return 0 ; + + $self->ckParams($got) + or $self->croakError("newStream: $self->{Error}"); + + *$self->{Header} = $self->mkHeader($got) ; + ${ *$self->{Buffer} } .= *$self->{Header} ; + + if (defined *$self->{FH}) + { + defined *$self->{FH}->write(${ *$self->{Buffer} }, + length ${ *$self->{Buffer} }) + or return $self->saveErrorString(0, $!, $!); + ${ *$self->{Buffer} } = '' ; + } + + my $status = *$self->{Compress}->reset() ; + return $self->saveErrorString(0, *$self->{Compress}{Error}, + *$self->{Compress}{ErrorNo}) + if $status == STATUS_ERROR; + + *$self->{BytesWritten} = 0 ; + *$self->{UnCompSize_32bit} = 0 ; + + return 1 ; +} + +sub _writeTrailer +{ + my $self = shift ; + + my $status = *$self->{Compress}->close(*$self->{Buffer}) ; + return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) + if $status == STATUS_ERROR; + + my $trailer = $self->mkTrailer(); + defined $trailer + or return 0; + + ${ *$self->{Buffer} } .= $trailer; + + return 1 if ! defined *$self->{FH} ; + + defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} }) + or return $self->saveErrorString(0, $!, $!); + + ${ *$self->{Buffer} } = '' ; + + return 1; +} + +sub _writeFinalTrailer +{ + my $self = shift ; + + ${ *$self->{Buffer} } .= $self->mkFinalTrailer(); + + return 1 if ! defined *$self->{FH} ; + + defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} }) + or return $self->saveErrorString(0, $!, $!); + + ${ *$self->{Buffer} } = '' ; + + return 1; +} + +sub close +{ + my $self = shift ; + + return 1 if *$self->{Closed} || ! *$self->{Compress} ; + *$self->{Closed} = 1 ; + + untie *$self + if $] >= 5.008 ; + + $self->_writeTrailer() + or return 0 ; + + $self->_writeFinalTrailer() + or return 0 ; + + if (defined *$self->{FH}) { + #if (! *$self->{Handle} || *$self->{AutoClose}) { + if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { + $! = 0 ; + *$self->{FH}->close() + or return $self->saveErrorString(0, $!, $!); + } + delete *$self->{FH} ; + # This delete can set $! in older Perls, so reset the errno + $! = 0 ; + } + + return 1; +} + + +#sub total_in +#sub total_out +#sub msg +# +#sub crc +#{ +# my $self = shift ; +# return *$self->{Compress}->crc32() ; +#} +# +#sub msg +#{ +# my $self = shift ; +# return *$self->{Compress}->msg() ; +#} +# +#sub dict_adler +#{ +# my $self = shift ; +# return *$self->{Compress}->dict_adler() ; +#} +# +#sub get_Level +#{ +# my $self = shift ; +# return *$self->{Compress}->get_Level() ; +#} +# +#sub get_Strategy +#{ +# my $self = shift ; +# return *$self->{Compress}->get_Strategy() ; +#} + + +sub tell +{ + my $self = shift ; + + #return *$self->{Compress}->total_in(); + return *$self->{BytesWritten} ; +} + +sub eof +{ + my $self = shift ; + + return *$self->{Closed} ; +} + + +sub seek +{ + my $self = shift ; + my $position = shift; + my $whence = shift ; + + my $here = $self->tell() ; + my $target = 0 ; + + #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + use IO::Handle ; + + if ($whence == IO::Handle::SEEK_SET) { + $target = $position ; + } + elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) { + $target = $here + $position ; + } + else { + $self->croakError(*$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter"); + } + + # short circuit if seeking to current offset + return 1 if $target == $here ; + + # Outlaw any attempt to seek backwards + $self->croakError(*$self->{ClassName} . "::seek: cannot seek backwards") + if $target < $here ; + + # Walk the file to the new offset + my $offset = $target - $here ; + + my $buffer ; + defined $self->syswrite("\x00" x $offset) + or return 0; + + return 1 ; +} + +sub binmode +{ + 1; +# my $self = shift ; +# return defined *$self->{FH} +# ? binmode *$self->{FH} +# : 1 ; +} + +sub fileno +{ + my $self = shift ; + return defined *$self->{FH} + ? *$self->{FH}->fileno() + : undef ; +} + +sub _notAvailable +{ + my $name = shift ; + return sub { croak "$name Not Available: File opened only for output" ; } ; +} + +*read = _notAvailable('read'); +*READ = _notAvailable('read'); +*readline = _notAvailable('readline'); +*READLINE = _notAvailable('readline'); +*getc = _notAvailable('getc'); +*GETC = _notAvailable('getc'); + +*FILENO = \&fileno; +*PRINT = \&print; +*PRINTF = \&printf; +*WRITE = \&syswrite; +*write = \&syswrite; +*SEEK = \&seek; +*TELL = \&tell; +*EOF = \&eof; +*CLOSE = \&close; +*BINMODE = \&binmode; + +#*sysread = \&_notAvailable; +#*syswrite = \&_write; + +1; + +__END__ + diff --git a/ext/Compress/Zlib/lib/IO/Compress/Deflate.pm b/ext/Compress/Zlib/lib/IO/Compress/Deflate.pm index 8e7e72438b..de438f363f 100644 --- a/ext/Compress/Zlib/lib/IO/Compress/Deflate.pm +++ b/ext/Compress/Zlib/lib/IO/Compress/Deflate.pm @@ -2,35 +2,162 @@ package IO::Compress::Deflate ; use strict ; use warnings; + require Exporter ; -use IO::Compress::Gzip ; +use IO::Compress::RawDeflate; + +use Compress::Zlib 2 ; +use Compress::Zlib::FileConstants; +use Compress::Zlib::Common qw(createSelfTiedObject); our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError); -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; $DeflateError = ''; -@ISA = qw(Exporter IO::BaseDeflate); +@ISA = qw(Exporter IO::Compress::RawDeflate); @EXPORT_OK = qw( $DeflateError deflate ) ; -%EXPORT_TAGS = %IO::BaseDeflate::EXPORT_TAGS ; +%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; Exporter::export_ok_tags('all'); - sub new { - my $pkg = shift ; - return IO::BaseDeflate::new($pkg, 'rfc1950', undef, \$DeflateError, @_); + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$DeflateError); + return $obj->_create(undef, @_); } sub deflate { - return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1950', \$DeflateError, @_); + 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; @@ -61,7 +188,7 @@ IO::Compress::Deflate - Perl interface to write RFC 1950 files/buffers $z->seek($position, $whence); $z->binmode(); $z->fileno(); - $z->newStream(); + $z->newStream( [OPTS] ); $z->deflateParams(); $z->close() ; @@ -114,24 +241,25 @@ 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. +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"; - deflate \%hash [,OPTS] - or die "deflate failed: $DeflateError\n"; + The functional interface needs Perl5.005 or better. =head2 deflate $input => $output [, OPTS] -If the first parameter is not a hash reference C<deflate> expects -at least two parameters, C<$input> and C<$output>. + +C<deflate> expects at least two parameters, C<$input> and C<$output>. =head3 The C<$input> parameter @@ -161,13 +289,15 @@ from C<$$input>. =item An array reference -If C<$input> is an array reference, the input data will be read from each -element of the array in turn. The action taken by C<deflate> with -each element of the array will depend on the type of data stored -in it. You can mix and match any of the types defined in this list, -excluding other array or hash references. +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 data types before any data is compressed. +contains valid filenames before any data is compressed. + + =item An Input FileGlob string @@ -195,36 +325,28 @@ compressed data. This parameter can take one of these forms. =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. +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. +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 A Hash Reference - -If C<$output> is a hash reference, the compressed data will be written -to C<$output{$input}> as a scalar reference. +If C<$output> is a scalar reference, the compressed data will be +stored in C<$$output>. -When C<$output> is a hash reference, C<$input> must be either a filename or -list of filenames. Anything else is an error. =item An Array Reference -If C<$output> is an array reference, the compressed data will be pushed -onto the array. +If C<$output> is an array reference, the compressed data will be +pushed onto the array. =item An Output FileGlob @@ -239,60 +361,13 @@ string. Anything else is an error. If the C<$output> parameter is any other type, C<undef> will be returned. -=head2 deflate \%hash [, OPTS] -If the first parameter is a hash reference, C<\%hash>, this will be used to -define both the source of uncompressed data and to control where the -compressed data is output. Each key/value pair in the hash defines a -mapping between an input filename, stored in the key, and an output -file/buffer, stored in the value. Although the input can only be a filename, -there is more flexibility to control the destination of the compressed -data. This is determined by the type of the value. Valid types are - -=over 5 - -=item undef - -If the value is C<undef> the compressed data will be written to the -value as a scalar reference. - -=item A filename - -If the value 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 value 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 the value is a scalar reference, the compressed data will be stored -in the buffer that is referenced by the scalar. - - -=item A Hash Reference - -If the value is a hash reference, the compressed data will be written -to C<$hash{$input}> as a scalar reference. - -=item An Array Reference - -If C<$output> is an array reference, the compressed data will be pushed -onto the array. - -=back - -Any other type is a error. =head2 Notes When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the compressed input files/buffers will all be stored in -C<$output> as a single compressed stream. +file/buffer the compressed input files/buffers will all be stored +in C<$output> as a single compressed stream. @@ -306,8 +381,8 @@ L</"Constructor Options"> section below. =item AutoClose =E<gt> 0|1 -This option applies to any input or output data streams to C<deflate> -that are filehandles. +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 @@ -317,6 +392,16 @@ This parameter defaults to 0. +=item BinModeIn =E<gt> 0|1 + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + + + + + =item -Append =E<gt> 0|1 TODO @@ -437,9 +522,9 @@ C<OPTS> is any combination of the following options: =item -AutoClose =E<gt> 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. +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. @@ -447,27 +532,27 @@ This parameter defaults to 0. Opens C<$output> in append mode. -The behaviour of this option is dependant on the type of C<$output>. +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. +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. +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. +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 @@ -481,8 +566,8 @@ 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. +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1950 data stream. @@ -492,8 +577,9 @@ There are a number of other limitations with the C<Merge> option: =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. +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 @@ -564,7 +650,7 @@ Usage is print $z $data Compresses and outputs the contents of the C<$data> parameter. This -has the same behavior as the C<print> built-in. +has the same behaviour as the C<print> built-in. Returns true if successful. @@ -727,13 +813,24 @@ underlying file will also be closed. -=head2 newStream +=head2 newStream([OPTS]) Usage is - $z->newStream + $z->newStream( [OPTS] ) -TODO +Closes the current compressed data stream and starts a new one. + +OPTS consists of the following sub-set of the the options that are +available when creating the C<$z> object, + +=over 5 + +=item * Level + +=item * TODO + +=back =head2 deflateParams @@ -843,7 +940,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005 Paul Marquess. All rights reserved. +Copyright (c) 2005-2006 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/Compress/Zlib/lib/IO/Compress/Gzip.pm b/ext/Compress/Zlib/lib/IO/Compress/Gzip.pm index e8e070ba54..840a687f0d 100644 --- a/ext/Compress/Zlib/lib/IO/Compress/Gzip.pm +++ b/ext/Compress/Zlib/lib/IO/Compress/Gzip.pm @@ -6,216 +6,194 @@ require 5.004 ; use strict ; use warnings; -# create RFC1952 + +use IO::Compress::RawDeflate; + +use Compress::Zlib 2 ; +use Compress::Zlib::Common qw(:Status createSelfTiedObject); +use Compress::Gzip::Constants; + +BEGIN +{ + if (defined &utf8::downgrade ) + { *noUTF8 = \&utf8::downgrade } + else + { *noUTF8 = sub {} } +} require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError); -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; $GzipError = '' ; -@ISA = qw(Exporter IO::BaseDeflate); +@ISA = qw(Exporter IO::Compress::RawDeflate); @EXPORT_OK = qw( $GzipError gzip ) ; -%EXPORT_TAGS = %IO::BaseDeflate::EXPORT_TAGS ; +%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; Exporter::export_ok_tags('all'); sub new { - my $pkg = shift ; - return IO::BaseDeflate::new($pkg, 'rfc1952', undef, \$GzipError, @_); + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$GzipError); + + $obj->_create(undef, @_); } sub gzip { - return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1952', \$GzipError, @_); + my $obj = createSelfTiedObject(undef, \$GzipError); + return $obj->_def(@_); } -package IO::BaseDeflate; - +#sub newHeader +#{ +# my $self = shift ; +# #return GZIP_MINIMUM_HEADER ; +# return $self->mkHeader(*$self->{Got}); +#} -use Compress::Zlib 2 ; -use Compress::Zlib::Common; -use Compress::Zlib::FileConstants; -use Compress::Zlib::ParseParameters; -use Compress::Gzip::Constants; -use IO::Uncompress::Gunzip; +sub getExtraParams +{ + my $self = shift ; -use IO::File ; -#use File::Glob; -require Exporter ; -use Carp ; -use Symbol; -use bytes; - -our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS, $got_encode); -@ISA = qw(Exporter IO::File); -%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 - }], - - ); + use Compress::Zlib::ParseParameters; + + return ( + # zlib behaviour + $self->getZlibParams(), -{ - my %seen; - foreach (keys %EXPORT_TAGS ) - { - push @{$EXPORT_TAGS{constants}}, - grep { !$seen{$_}++ } - @{ $EXPORT_TAGS{$_} } - } - $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ; + # 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::Zlib::gzip_os_code], + 'ExtraField'=> [0, 1, Parse_string, undef], + 'ExtraFlags'=> [0, 1, Parse_any, undef], + + ); } -Exporter::export_ok_tags('all'); - -BEGIN +sub ckParams { - if (defined &utf8::downgrade ) - { *noUTF8 = \&utf8::downgrade } - else - { *noUTF8 = sub {} } -} - + my $self = shift ; + my $got = shift ; -$VERSION = '2.000_03'; + # gzip always needs crc32 + $got->value('CRC32' => 1); -#Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16. + return 1 + if $got->value('Merge') ; -#$got_encode = 0; -#eval -#{ -# require Encode; -# Encode->import('encode', 'find_encoding'); -#}; -# -#$got_encode = 1 unless $@; + my $lax = ! $got->value('Strict') ; -sub saveStatus -{ - my $self = shift ; - ${ *$self->{ErrorNo} } = shift() + 0 ; - ${ *$self->{Error} } = '' ; - return ${ *$self->{ErrorNo} } ; -} + { + 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 ! $lax && $name =~ /\x00/ ; -sub saveErrorString -{ - my $self = shift ; - my $retval = shift ; - ${ *$self->{Error} } = shift ; - ${ *$self->{ErrorNo} } = shift() + 0 if @_ ; + return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Name", + Z_DATA_ERROR) + if ! $lax && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; + } - return $retval; -} + if ($got->parsed('Comment') && defined $got->value('Comment')) { + my $comment = $got->value('Comment'); -sub error -{ - my $self = shift ; - return ${ *$self->{Error} } ; -} + return $self->saveErrorString(undef, "Null Character found in Comment", + Z_DATA_ERROR) + if ! $lax && $comment =~ /\x00/ ; -sub errorNo -{ - my $self = shift ; - return ${ *$self->{ErrorNo} } ; -} + return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment", + Z_DATA_ERROR) + if ! $lax && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o; + } -sub bitmask($$$$) -{ - my $into = shift ; - my $value = shift ; - my $offset = shift ; - my $mask = shift ; + if ($got->parsed('OS_Code') ) { + my $value = $got->value('OS_Code'); - return $into | (($value & $mask) << $offset ) ; -} + return $self->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'") + if $value < 0 || $value > 255 ; + + } -sub mkDeflateHdr($$$;$) -{ - my $method = shift ; - my $cinfo = shift; - my $level = shift; - my $fdict_adler = shift ; + # gzip only supports Deflate at present + $got->value('Method' => Z_DEFLATED) ; - my $cmf = 0; - my $flg = 0; - my $fdict = 0; - $fdict = 1 if defined $fdict_adler; + 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 ; + } - $cmf = bitmask($cmf, $method, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS); - $cmf = bitmask($cmf, $cinfo, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS); + if ($got->parsed('ExtraField')) { - $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 $bad = $self->parseExtraField($got, $lax) ; + return $self->saveErrorString(undef, $bad, Z_DATA_ERROR) + if $bad ; - my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ; - $flg = bitmask($flg, $fcheck, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS); + my $len = length $got->value('ExtraField') ; + return $self->saveErrorString(undef, ExtraFieldError("Too Large"), + Z_DATA_ERROR) + if $len > GZIP_FEXTRA_MAX_SIZE; + } + } - my $hdr = pack("CC", $cmf, $flg) ; - $hdr .= pack("N", $fdict_adler) if $fdict ; + return 1; +} - return $hdr; +sub mkTrailer +{ + my $self = shift ; + return pack("V V", *$self->{Compress}->crc32(), + *$self->{UnCompSize_32bit}); } -sub mkDeflateHeader ($) +sub getInverseClass { - my $param = shift ; + return ('IO::Uncompress::Gunzip', + \$IO::Uncompress::Gunzip::GunzipError); +} - my $level = $param->value('Level'); - my $strategy = $param->value('Strategy'); +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $filename = shift ; - my $lflag ; - $level = 6 - if $level == Z_DEFAULT_COMPRESSION ; + my $defaultTime = (stat($filename))[9] ; - 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 ; - } + $params->value('Name' => $filename) + if ! $params->parsed('Name') ; - #my $wbits = (MAX_WBITS - 8) << 4 ; - my $wbits = 7; - mkDeflateHdr(ZLIB_CMF_CM_DEFLATED, $wbits, $lflag); + $params->value('Time' => $defaultTime) + if ! $params->parsed('Time') ; } -sub mkGzipHeader + +sub mkHeader { + my $self = shift ; my $param = shift ; # stort-circuit if a minimal header is requested. @@ -440,1084 +418,11 @@ sub parseExtraField return undef; } -sub checkParams -{ - my $class = shift ; - my $type = shift ; - - my $rfc1952 = ($type eq 'rfc1952'); - my $rfc1950 = ($type eq 'rfc1950'); - - my $got = Compress::Zlib::ParseParameters::new(); - - $got->parse( - $rfc1952 ? - { - 'AutoClose'=> [Parse_boolean, 0], - #'Encoding'=> [Parse_any, undef], - 'Strict' => [Parse_boolean, 1], - 'Append' => [Parse_boolean, 0], - 'Merge' => [Parse_boolean, 0], - 'BinModeIn' => [Parse_boolean, 0], - - # zlib behaviour - #'Method' => [Parse_unsigned, Z_DEFLATED], - 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION], - 'Strategy' => [Parse_signed, Z_DEFAULT_STRATEGY], - - # Gzip header fields - 'Minimal' => [Parse_boolean, 0], - 'Comment' => [Parse_any, undef], - 'Name' => [Parse_any, undef], - 'Time' => [Parse_any, undef], - 'TextFlag' => [Parse_boolean, 0], - 'HeaderCRC' => [Parse_boolean, 0], - 'OS_Code' => [Parse_unsigned, $Compress::Zlib::gzip_os_code], - 'ExtraField'=> [Parse_string, undef], - 'ExtraFlags'=> [Parse_any, undef], - } - : - { - 'AutoClose' => [Parse_boolean, 0], - #'Encoding' => [Parse_any, undef], - 'CRC32' => [Parse_boolean, 0], - 'ADLER32' => [Parse_boolean, 0], - 'Strict' => [Parse_boolean, 1], - 'Append' => [Parse_boolean, 0], - 'Merge' => [Parse_boolean, 0], - 'BinModeIn' => [Parse_boolean, 0], - - # zlib behaviour - #'Method' => [Parse_unsigned, Z_DEFLATED], - 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION], - 'Strategy' => [Parse_signed, Z_DEFAULT_STRATEGY], - }, - @_) or croak "${class}: $got->{Error}" ; - - return $got ; -} - -sub new -{ - my $class = shift ; - my $type = shift ; - my $got = shift; - my $error_ref = shift ; - - croak("$class: Missing Output parameter") - if ! @_ && ! $got ; - - my $outValue = shift ; - my $oneShot = 1 ; - - if (! $got) - { - $oneShot = 0 ; - $got = checkParams($class, $type, @_) - or return undef ; - } - - my $rfc1952 = ($type eq 'rfc1952'); - my $rfc1950 = ($type eq 'rfc1950'); - my $rfc1951 = ($type eq 'rfc1951'); - - my $obj = bless Symbol::gensym(), ref($class) || $class; - tie *$obj, $obj if $] >= 5.005; - - *$obj->{Closed} = 1 ; - $$error_ref = '' ; - *$obj->{Error} = $error_ref ; - - my $lax = ! $got->value('Strict') ; - - my $outType = whatIsOutput($outValue); - - ckOutputParam($class, $outValue, $error_ref) - or return undef ; - - if ($outType eq 'buffer') { - *$obj->{Buffer} = $outValue; - } - else { - my $buff = "" ; - *$obj->{Buffer} = \$buff ; - } - - # Merge implies Append - my $merge = $got->value('Merge') ; - my $appendOutput = $got->value('Append') || $merge ; - - if ($merge) - { - # Switch off Merge mode if output file/buffer is empty/doesn't exist - if (($outType eq 'buffer' && length $$outValue == 0 ) || - ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) ) - { $merge = 0 } - } - - # If output is a file, check that it is writable - if ($outType eq 'filename' && -e $outValue && ! -w _) - { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) } - - elsif ($outType eq 'handle' && ! -w $outValue) - { return $obj->saveErrorString(undef, "Output filehandle is not writable" ) } - - -# TODO - encoding -# if ($got->parsed('Encoding')) { -# croak("$class: Encode module needed to use -Encoding") -# if ! $got_encode; -# -# my $want_encoding = $got->value('Encoding'); -# my $encoding = find_encoding($want_encoding); -# -# croak("$class: Encoding '$want_encoding' is not available") -# if ! $encoding; -# -# *$obj->{Encoding} = $encoding; -# } - - if ($rfc1952 && ! $merge) { - - 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 $obj->saveErrorString(undef, "Null Character found in Name", - Z_DATA_ERROR) - if ! $lax && $name =~ /\x00/ ; - - return $obj->saveErrorString(undef, "Non ISO 8859-1 Character found in Name", - Z_DATA_ERROR) - if ! $lax && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; - } - - if ($got->parsed('Comment') && defined $got->value('Comment')) { - my $comment = $got->value('Comment'); - - return $obj->saveErrorString(undef, "Null Character found in Comment", - Z_DATA_ERROR) - if ! $lax && $comment =~ /\x00/ ; - - return $obj->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment", - Z_DATA_ERROR) - if ! $lax && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o; - } - - if ($got->parsed('OS_Code') ) { - my $value = $got->value('OS_Code'); - - return $obj->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 ; - } - - if ($got->parsed('ExtraField')) { - - my $bad = $obj->parseExtraField($got, $lax) ; - return $obj->saveErrorString(undef, $bad, Z_DATA_ERROR) - if $bad ; - - my $len = length $got->value('ExtraField') ; - return $obj->saveErrorString(undef, ExtraFieldError("Too Large"), - Z_DATA_ERROR) - if $len > GZIP_FEXTRA_MAX_SIZE; - } - } - - $obj->saveStatus(Z_OK) ; - - my $end_offset = 0; - my $status ; - if (! $merge) - { - (*$obj->{Deflate}, $status) = new Compress::Zlib::Deflate - -AppendOutput => 1, - -CRC32 => $rfc1952 || $got->value('CRC32'), - -ADLER32 => $rfc1950 || $got->value('ADLER32'), - -Level => $got->value('Level'), - -Strategy => $got->value('Strategy'), - -WindowBits => - MAX_WBITS; - return $obj->saveErrorString(undef, "Cannot create Deflate object: $status" ) - if $obj->saveStatus($status) != Z_OK ; - - *$obj->{BytesWritten} = 0 ; - *$obj->{ISize} = 0 ; - - *$obj->{Header} = mkDeflateHeader($got) - if $rfc1950 ; - *$obj->{Header} = '' - if $rfc1951 ; - *$obj->{Header} = mkGzipHeader($got) - if $rfc1952 ; - - if ( $outType eq 'buffer') { - ${ *$obj->{Buffer} } = '' - unless $appendOutput ; - ${ *$obj->{Buffer} } .= *$obj->{Header}; - } - else { - if ($outType eq 'handle') { - $outValue->flush() ; - *$obj->{FH} = $outValue ; - setBinModeOutput(*$obj->{FH}) ; - *$obj->{Handle} = 1 ; - if ($appendOutput) - { - seek(*$obj->{FH}, 0, SEEK_END) - or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; - - } - } - elsif ($outType eq 'filename') { - my $mode = '>' ; - $mode = '>>' - if $appendOutput; - *$obj->{FH} = new IO::File "$mode $outValue" - or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ; - *$obj->{StdIO} = ($outValue eq '-'); - setBinModeOutput(*$obj->{FH}) ; - } - - if (!$rfc1951) { - defined *$obj->{FH}->write(*$obj->{Header}, length(*$obj->{Header})) - or return $obj->saveErrorString(undef, $!, $!) ; - } - } - } - else - { - my %mapping = ( 'rfc1952' => ['IO::Uncompress::Gunzip', \$IO::Uncompress::Gunzip::GunzipError], - 'rfc1950' => ['IO::Uncompress::Inflate', \$IO::Uncompress::Inflate::InflateError], - 'rfc1951' => ['IO::Uncompress::RawInflate', \$IO::Uncompress::RawInflate::RawInflateError], - ); - - my $inf = IO::BaseInflate::new($mapping{$type}[0], - $type, undef, - $error_ref, 0, $outValue, - Transparent => 0, - #Strict => 1, - AutoClose => 0, - Scan => 1); - - return $obj->saveErrorString(undef, "Cannot create InflateScan object: $$error_ref" ) - if ! defined $inf ; - - $inf->scan() - or return $obj->saveErrorString(undef, "Error Scanning: $$error_ref", $inf->errorNo) ; - $inf->zap($end_offset) - or return $obj->saveErrorString(undef, "Error Zapping: $$error_ref", $inf->errorNo) ; - - (*$obj->{Deflate}, $status) = $inf->createDeflate(); - - *$obj->{Header} = *$inf->{Info}{Header}; - *$obj->{ISize} = - *$obj->{ISize} = *$obj->{BytesWritten} = *$inf->{ISize} ; - - if ( $outType eq 'buffer') - { substr( ${ *$obj->{Buffer} }, $end_offset) = '' } - elsif ($outType eq 'handle' || $outType eq 'filename') { - *$obj->{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, $!, $!) ; - } - } - - *$obj->{Closed} = 0 ; - *$obj->{AutoClose} = $got->value('AutoClose') ; - *$obj->{OutputGzip} = $rfc1952; - *$obj->{OutputDeflate} = $rfc1950; - *$obj->{OutputRawDeflate} = $rfc1951; - *$obj->{Output} = $outValue; - *$obj->{ClassName} = $class; - *$obj->{Got} = $got; - - return $obj ; -} - -sub _def -{ - my $class = shift ; - my $type = shift ; - my $error_ref = shift ; - - my $name = (caller(1))[3] ; - - croak "$name: expected at least 1 parameters\n" - unless @_ >= 1 ; - - my $input = shift ; - my $haveOut = @_ ; - my $output = shift ; - - my $x = new Validator($class, $type, $error_ref, $name, $input, $output) - or return undef ; - - push @_, $output if $haveOut && $x->{Hash}; - - my $got = checkParams($name, $type, @_) - or return undef ; - - $x->{Got} = $got ; - $x->{ParsedTime} = $got->parsed('Time') ; - $x->{ParsedName} = $got->parsed('Name') ; - - if ($x->{Hash}) - { - while (my($k, $v) = each %$input) - { - $v = \$input->{$k} - unless defined $v ; - - _singleTarget($x, 1, $k, $v, @_) - or return undef ; - } - - return keys %$input ; - } - - if ($x->{GlobMap}) - { - $x->{oneInput} = 1 ; - foreach my $pair (@{ $x->{Pairs} }) - { - my ($from, $to) = @$pair ; - _singleTarget($x, 1, $from, $to, @_) - or return undef ; - } - - return scalar @{ $x->{Pairs} } ; - } - - if (! $x->{oneOutput} ) - { - my $inFile = ($x->{inType} eq 'filenames' - || $x->{inType} eq 'filename'); - - $x->{inType} = $inFile ? 'filename' : 'buffer'; - - foreach my $in ($x->{oneInput} ? $input : @$input) - { - my $out ; - $x->{oneInput} = 1 ; - - _singleTarget($x, $inFile, $in, \$out, @_) - or return undef ; - - if ($x->{outType} eq 'array') - { push @$output, \$out } - else - { $output->{$in} = \$out } - } - - return 1 ; - } - - # finally the 1 to 1 and n to 1 - return _singleTarget($x, 1, $input, $output, @_); - - croak "should not be here" ; -} - -sub _singleTarget -{ - my $x = shift ; - my $inputIsFilename = shift; - my $input = shift; - - - # For gzip, if input is simple filename, populate Name & Time in - # gzip header from filename by default. - if ($x->{Type} eq 'rfc1952' and isaFilename($input) and $inputIsFilename) - { - my $defaultTime = (stat($input))[8] ; - - $x->{Got}->value('Name' => $input) - if ! $x->{ParsedName}; - - $x->{Got}->value('Time' => $defaultTime) - if ! $x->{ParsedTime}; - } - - my $gzip = new($x->{Class}, $x->{Type}, $x->{Got}, $x->{Error}, @_) - or return undef ; - - - if ($x->{oneInput}) - { - defined $gzip->_wr2($input, $inputIsFilename) - or return undef ; - } - else - { - my $afterFirst = 0 ; - my $inputIsFilename = ($x->{inType} ne 'array'); - - for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) - { - if ( $afterFirst ++ ) - { - defined addInterStream($gzip, $x, $element, $inputIsFilename) - or return undef ; - } - - defined $gzip->_wr2($element, $inputIsFilename) - or return undef ; - } - } - - return $gzip->close() ; -} - -sub _wr2 -{ - my $self = shift ; - - my $source = shift ; - my $inputIsFilename = shift; - - my $input = $source ; - if (! $inputIsFilename) - { - $input = \$source - if ! ref $source; - } - - if ( ref $input && ref $input eq 'SCALAR' ) - { - return $self->syswrite($input, @_) ; - } - - if ( ! ref $input || isaFilehandle($input)) - { - my $isFilehandle = isaFilehandle($input) ; - - my $fh = $input ; - - if ( ! $isFilehandle ) - { - $fh = new IO::File "<$input" - or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ; - } - binmode $fh if *$self->{Got}->valueOrDefault('BinModeIn') ; - - my $status ; - my $buff ; - my $count = 0 ; - while (($status = read($fh, $buff, 4096)) > 0) { - $count += length $buff; - defined $self->syswrite($buff, @_) - or return undef ; - } - - return $self->saveErrorString(undef, $!, $!) - if $status < 0 ; - - if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-') - { - $fh->close() - or return undef ; - } - - return $count ; - } - - croak "Should no be here"; - return undef; -} - -sub addInterStream +sub mkFinalTrailer { - my $gzip = shift ; - my $x = shift ; - my $input = shift ; - my $inputIsFilename = shift ; - - if ($x->{Got}->value('MultiStream')) - { - # For gzip, if input is simple filename, populate Name & Time in - # gzip header from filename by default. - if ($x->{Type} eq 'rfc1952' and isaFilename($input) and $inputIsFilename) - { - my $defaultTime = (stat($input))[8] ; - - $x->{Got}->value('Name' => $input) - if ! $x->{ParsedName}; - - $x->{Got}->value('Time' => $defaultTime) - if ! $x->{ParsedTime}; - } - - # TODO -- newStream needs to allow gzip header to be modified - return $gzip->newStream(); - } - elsif ($x->{Got}->value('AutoFlush')) - { - return $gzip->flush(Z_FULL_FLUSH); - } - - return 1 ; + return ''; } -sub TIEHANDLE -{ - return $_[0] if ref($_[0]); - die "OOPS\n" ; -} - -sub UNTIE -{ - my $self = shift ; -} - -sub DESTROY -{ - my $self = shift ; - $self->close() ; - - # TODO - memory leak with 5.8.0 - this isn't called until - # global destruction - # - %{ *$self } = () ; - undef $self ; -} - - -#sub validateInput -#{ -# my $class = shift ; -# -# #local $Carp::CarpLevel = 1; -# -# if ( ! ref $_[0] || -# ref $_[0] eq 'SCALAR' || -# #ref $_[0] eq 'CODE' || -# isaFilehandle($_[0]) ) -# { -# my $inType = whatIs($_[0]); -# my $outType = whatIs($_[1]); -# -# if ($inType eq 'filename' ) -# { -# croak "$class: input filename is undef or null string" -# if ! defined $_[0] || $_[0] eq '' ; -# -# if ($_[0] ne '-' && ! -e $_[0] ) -# { -# ${$_[2]} = "input file '$_[0]' does not exist"; -# $_[3] = $!; -# return undef; -# } -# -# if (! -r $_[0] ) -# { -# ${$_[2]} = "cannot open file '$_[0]': $!"; -# $_[3] = $!; -# return undef; -# } -# } -# elsif ($inType eq 'fileglob' ) -# { -# # whatever... -# } -# -# croak("$class: input and output $inType are identical") -# if defined $outType && $inType eq $outType && $_[0] eq $_[1] ; -# -# return 1 ; -# } -# -# croak "$class: input parameter not a filename, filehandle, array ref or scalar ref" -# unless ref $_[0] eq 'ARRAY' ; -# -# my $array = shift @_ ; -# foreach my $element ( @{ $array } ) -# { -# return undef -# unless validateInput($class, $element, @_); -# } -# -# return 1 ; -#} - - -#sub write -#{ -# my $self = shift ; -# -# if ( isaFilehandle $_[0] ) -# { -# return $self->_wr(@_); -# } -# -# if ( ref $_[0]) -# { -# if ( ref $_[0] eq 'SCALAR' ) -# { return $self->syswrite(@_) } -# -# if ( ref $_[0] eq 'ARRAY' ) -# { -# my ($str, $num); -# validateInput(*$self->{ClassName} . "::write", $_[0], *$self->{Output}, \$str, $num) -# or return $self->saveErrorString(undef, $str, $num); -# -# return $self->_wr(@_); -# } -# -# croak *$self->{ClassName} . "::write: input parameter not a filename, filehandle, array ref or scalar ref"; -# } -# -# # Not a reference or a filehandle -# return $self->syswrite(@_) ; -#} -# -#sub _wr -#{ -# my $self = shift ; -# -# if ( ref $_[0] && ref $_[0] eq 'SCALAR' ) -# { -# return $self->syswrite(@_) ; -# } -# -# if ( ! ref $_[0] || isaFilehandle($_[0])) -# { -# my $item = shift @_ ; -# my $isFilehandle = isaFilehandle($item) ; -# -# my $fh = $item ; -# -# if ( ! $isFilehandle ) -# { -# $fh = new IO::File "<$item" -# or return $self->saveErrorString(undef, "cannot open file '$item': $!", $!) ; -# } -# -# my $status ; -# my $buff ; -# my $count = 0 ; -# while (($status = read($fh, $buff, 4096)) > 0) { -# $count += length $buff; -# defined $self->syswrite($buff, @_) -# or return undef ; -# } -# -# return $self->saveErrorString(undef, $!, $!) -# if $status < 0 ; -# -# -# if ( !$isFilehandle || *$self->{AutoClose} ) -# { -# $fh->close() -# or return undef ; -# } -# -# return $count ; -# } -# -# #if ref $_[0] eq 'CODE' ; -# -# # then must be ARRAY ref -# my $count = 0 ; -# my $array = shift @_ ; -# foreach my $element ( @{ $array } ) -# { -# my $got = $self->_wr($element, @_) ; -# -# return undef -# unless defined $got ; -# -# $count += $got ; -# } -# -# return $count ; -#} - - -sub syswrite -{ - my $self = shift ; - - my $buffer ; - if (ref $_[0] ) { - croak *$self->{ClassName} . "::write: not a scalar reference" - unless ref $_[0] eq 'SCALAR' ; - $buffer = $_[0] ; - } - else { - $buffer = \$_[0] ; - } - - if (@_ > 1) { - my $slen = defined $$buffer ? length($$buffer) : 0; - my $len = $slen; - my $offset = 0; - $len = $_[1] if $_[1] < $len; - - if (@_ > 2) { - $offset = $_[2] || 0; - croak *$self->{ClassName} . "::write: offset outside string" if $offset > $slen; - if ($offset < 0) { - $offset += $slen; - croak *$self->{ClassName} . "::write: offset outside string" if $offset < 0; - } - my $rem = $slen - $offset; - $len = $rem if $rem < $len; - } - - $buffer = \substr($$buffer, $offset, $len) ; - } - - my $buffer_length = defined $$buffer ? length($$buffer) : 0 ; - *$self->{BytesWritten} += $buffer_length ; - my $rest = GZIP_ISIZE_MAX - *$self->{ISize} ; - if ($buffer_length > $rest) { - *$self->{ISize} = $buffer_length - $rest - 1; - } - else { - *$self->{ISize} += $buffer_length ; - } - -# if (*$self->{Encoding}) { -# $$buffer = *$self->{Encoding}->encode($$buffer); -# } - - #my $length = length $$buffer; - my $status = *$self->{Deflate}->deflate($buffer, *$self->{Buffer}) ; - - return $self->saveErrorString(undef,"Deflate Error: $status") - if $self->saveStatus($status) != Z_OK ; - - if ( defined *$self->{FH} and length ${ *$self->{Buffer} }) { - defined *$self->{FH}->write( ${ *$self->{Buffer} }, length ${ *$self->{Buffer} } ) - or return $self->saveErrorString(undef, $!, $!); - ${ *$self->{Buffer} } = '' ; - } - - return $buffer_length; -} - -sub print -{ - my $self = shift; - - #if (ref $self) { - # $self = *$self{GLOB} ; - #} - - if (defined $\) { - if (defined $,) { - defined $self->syswrite(join($,, @_) . $\); - } else { - defined $self->syswrite(join("", @_) . $\); - } - } else { - if (defined $,) { - defined $self->syswrite(join($,, @_)); - } else { - defined $self->syswrite(join("", @_)); - } - } -} - -sub printf -{ - my $self = shift; - my $fmt = shift; - defined $self->syswrite(sprintf($fmt, @_)); -} - - - -sub flush -{ - my $self = shift ; - my $opt = shift || Z_FINISH ; - my $status = *$self->{Deflate}->flush(*$self->{Buffer}, $opt) ; - return $self->saveErrorString(0,"Deflate Error: $status") - if $self->saveStatus($status) != Z_OK ; - - if ( defined *$self->{FH} ) { - *$self->{FH}->clearerr(); - defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} }) - or return $self->saveErrorString(0, $!, $!); - ${ *$self->{Buffer} } = '' ; - } - - return 1; -} - -sub newStream -{ - my $self = shift ; - - $self->_writeTrailer(GZIP_MINIMUM_HEADER) - or return 0 ; - - my $status = *$self->{Deflate}->deflateReset() ; - return $self->saveErrorString(0,"Deflate Error: $status") - if $self->saveStatus($status) != Z_OK ; - - *$self->{BytesWritten} = 0 ; - *$self->{ISize} = 0 ; - - return 1 ; -} - -sub _writeTrailer -{ - my $self = shift ; - my $nextHeader = shift || '' ; - - my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ; - return $self->saveErrorString(0,"Deflate Error: $status") - if $self->saveStatus($status) != Z_OK ; - - if (*$self->{OutputGzip}) { - ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(), - *$self->{ISize} ); - ${ *$self->{Buffer} } .= $nextHeader ; - } - - if (*$self->{OutputDeflate}) { - ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() ); - ${ *$self->{Buffer} } .= *$self->{Header} ; - } - - return 1 if ! defined *$self->{FH} ; - - defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} }) - or return $self->saveErrorString(0, $!, $!); - - ${ *$self->{Buffer} } = '' ; - - return 1; -} - -sub close -{ - my $self = shift ; - - return 1 if *$self->{Closed} || ! *$self->{Deflate} ; - *$self->{Closed} = 1 ; - - untie *$self - if $] >= 5.008 ; - - if (0) { - $self->_writeTrailer() - or return 0 ; - } - else { - - - my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ; - return $self->saveErrorString(0,"Deflate Error: $status") - if $self->saveStatus($status) != Z_OK ; - - if (*$self->{OutputGzip}) { - ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(), - *$self->{ISize} ); - } - - if (*$self->{OutputDeflate}) { - ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() ); - } - - - return 1 if ! defined *$self->{FH} ; - - defined *$self->{FH}->write(${ *$self->{Buffer} }, length( ${ *$self->{Buffer} } )) - or return $self->saveErrorString(0, $!, $!); - - ${ *$self->{Buffer} } = '' ; - } - - if (defined *$self->{FH}) { - #if (! *$self->{Handle} || *$self->{AutoClose}) { - if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { - $! = 0 ; - *$self->{FH}->close() - or return $self->saveErrorString(0, $!, $!); - } - delete *$self->{FH} ; - # This delete can set $! in older Perls, so reset the errno - $! = 0 ; - } - - return 1; -} - -sub deflateParams -{ - my $self = shift ; - my $level = shift ; - my $strategy = shift ; - - my $status = *$self->{Deflate}->deflateParams(-Level => $level, - -Strategy => $strategy) ; - return $self->saveErrorString(0,"deflateParams Error: $status") - if $self->saveStatus($status) != Z_OK ; - - return 1; -} - - -#sub total_in -#sub total_out -#sub msg -# -#sub crc -#{ -# my $self = shift ; -# return *$self->{Deflate}->crc32() ; -#} -# -#sub msg -#{ -# my $self = shift ; -# return *$self->{Deflate}->msg() ; -#} -# -#sub dict_adler -#{ -# my $self = shift ; -# return *$self->{Deflate}->dict_adler() ; -#} -# -#sub get_Level -#{ -# my $self = shift ; -# return *$self->{Deflate}->get_Level() ; -#} -# -#sub get_Strategy -#{ -# my $self = shift ; -# return *$self->{Deflate}->get_Strategy() ; -#} - - -sub tell -{ - my $self = shift ; - - #return *$self->{Deflate}->total_in(); - return *$self->{BytesWritten} ; -} - -sub eof -{ - my $self = shift ; - - return *$self->{Closed} ; -} - - -sub seek -{ - my $self = shift ; - my $position = shift; - my $whence = shift ; - - my $here = $self->tell() ; - my $target = 0 ; - - #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - use IO::Handle ; - - if ($whence == IO::Handle::SEEK_SET) { - $target = $position ; - } - elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) { - $target = $here + $position ; - } - else { - croak *$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter"; - } - - # short circuit if seeking to current offset - return 1 if $target == $here ; - - # Outlaw any attempt to seek backwards - croak *$self->{ClassName} . "::seek: cannot seek backwards" - if $target < $here ; - - # Walk the file to the new offset - my $offset = $target - $here ; - - my $buffer ; - defined $self->syswrite("\x00" x $offset) - or return 0; - - return 1 ; -} - -sub binmode -{ - 1; -# my $self = shift ; -# return defined *$self->{FH} -# ? binmode *$self->{FH} -# : 1 ; -} - -sub fileno -{ - my $self = shift ; - return defined *$self->{FH} - ? *$self->{FH}->fileno() - : undef ; -} - -sub _notAvailable -{ - my $name = shift ; - return sub { croak "$name Not Available: File opened only for output" ; } ; -} - -*read = _notAvailable('read'); -*READ = _notAvailable('read'); -*readline = _notAvailable('readline'); -*READLINE = _notAvailable('readline'); -*getc = _notAvailable('getc'); -*GETC = _notAvailable('getc'); - -*FILENO = \&fileno; -*PRINT = \&print; -*PRINTF = \&printf; -*WRITE = \&syswrite; -*write = \&syswrite; -*SEEK = \&seek; -*TELL = \&tell; -*EOF = \&eof; -*CLOSE = \&close; -*BINMODE = \&binmode; - -#*sysread = \&_notAvailable; -#*syswrite = \&_write; - 1; __END__ @@ -1547,7 +452,7 @@ IO::Compress::Gzip - Perl interface to write RFC 1952 files/buffers $z->seek($position, $whence); $z->binmode(); $z->fileno(); - $z->newStream(); + $z->newStream( [OPTS] ); $z->deflateParams(); $z->close() ; @@ -1603,24 +508,25 @@ 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. +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"; - gzip \%hash [,OPTS] - or die "gzip failed: $GzipError\n"; + The functional interface needs Perl5.005 or better. =head2 gzip $input => $output [, OPTS] -If the first parameter is not a hash reference C<gzip> expects -at least two parameters, C<$input> and C<$output>. + +C<gzip> expects at least two parameters, C<$input> and C<$output>. =head3 The C<$input> parameter @@ -1650,13 +556,15 @@ from C<$$input>. =item An array reference -If C<$input> is an array reference, the input data will be read from each -element of the array in turn. The action taken by C<gzip> with -each element of the array will depend on the type of data stored -in it. You can mix and match any of the types defined in this list, -excluding other array or hash references. +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 data types before any data is compressed. +contains valid filenames before any data is compressed. + + =item An Input FileGlob string @@ -1680,10 +588,11 @@ two of the gzip header fields created by this function will be sourced from that file -- the NAME gzip header field will be populated with the filename itself, and the MTIME header field will be set to the modification time of the file. -The intention here is to mirror part of the behavior of the gzip +The intention here is to mirror part of the behaviour of the gzip executable. If you do not want to use these defaults they can be overridden by -explicitly setting the C<Name> and C<Time> options. +explicitly setting the C<Name> and C<Time> options or by setting the +C<Minimal> parameter. @@ -1696,36 +605,28 @@ compressed data. This parameter can take one of these forms. =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. +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. +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>. - +If C<$output> is a scalar reference, the compressed data will be +stored in C<$$output>. -=item A Hash Reference - -If C<$output> is a hash reference, the compressed data will be written -to C<$output{$input}> as a scalar reference. - -When C<$output> is a hash reference, C<$input> must be either a filename or -list of filenames. Anything else is an error. =item An Array Reference -If C<$output> is an array reference, the compressed data will be pushed -onto the array. +If C<$output> is an array reference, the compressed data will be +pushed onto the array. =item An Output FileGlob @@ -1740,60 +641,13 @@ string. Anything else is an error. If the C<$output> parameter is any other type, C<undef> will be returned. -=head2 gzip \%hash [, OPTS] - -If the first parameter is a hash reference, C<\%hash>, this will be used to -define both the source of uncompressed data and to control where the -compressed data is output. Each key/value pair in the hash defines a -mapping between an input filename, stored in the key, and an output -file/buffer, stored in the value. Although the input can only be a filename, -there is more flexibility to control the destination of the compressed -data. This is determined by the type of the value. Valid types are - -=over 5 - -=item undef - -If the value is C<undef> the compressed data will be written to the -value as a scalar reference. - -=item A filename - -If the value 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 value 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 the value is a scalar reference, the compressed data will be stored -in the buffer that is referenced by the scalar. - - -=item A Hash Reference - -If the value is a hash reference, the compressed data will be written -to C<$hash{$input}> as a scalar reference. - -=item An Array Reference - -If C<$output> is an array reference, the compressed data will be pushed -onto the array. - -=back - -Any other type is a error. =head2 Notes When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the compressed input files/buffers will all be stored in -C<$output> as a single compressed stream. +file/buffer the compressed input files/buffers will all be stored +in C<$output> as a single compressed stream. @@ -1807,8 +661,8 @@ L</"Constructor Options"> section below. =item AutoClose =E<gt> 0|1 -This option applies to any input or output data streams to C<gzip> -that are filehandles. +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 @@ -1818,6 +672,16 @@ This parameter defaults to 0. +=item BinModeIn =E<gt> 0|1 + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + + + + + =item -Append =E<gt> 0|1 TODO @@ -1938,9 +802,9 @@ C<OPTS> is any combination of the following options: =item -AutoClose =E<gt> 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. +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. @@ -1948,27 +812,27 @@ This parameter defaults to 0. Opens C<$output> in append mode. -The behaviour of this option is dependant on the type of C<$output>. +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. +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. +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. +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 @@ -1982,8 +846,8 @@ 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. +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1952 data stream. @@ -1993,8 +857,9 @@ There are a number of other limitations with the C<Merge> option: =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. +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 @@ -2041,7 +906,7 @@ The default is Z_DEFAULT_STRATEGY. -=item -Mimimal =E<gt> 0|1 +=item -Minimal =E<gt> 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 @@ -2089,29 +954,29 @@ if this option is not specified. =item -TextFlag =E<gt> 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. +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 -HeaderCRC =E<gt> 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. +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 -maximise the portability of your gzip files. +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 -OS_Code =E<gt> $value -Stores C<$value> in the gzip OS header field. A number between 0 and -255 is valid. +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 @@ -2119,10 +984,10 @@ Unix variants and unknown Operating Systems. =item -ExtraField =E<gt> $data -This parameter allows additional metadata to be stored in the ExtraField in the -gzip header. An RFC1952 compliant ExtraField consists of zero or more -subfields. Each subfield consists of a two byte header followed by the subfield -data. +This parameter allows additional metadata to be stored in the ExtraField in +the gzip header. An RFC1952 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 @@ -2161,8 +1026,8 @@ The maximum size of the Extra Field 65535 bytes. 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 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 =E<gt> Z_BEST_SPEED> has been specified then XFL is set to 2. If C<Level =E<gt> Z_BEST_COMPRESSION> has been specified then XFL is set to 4. @@ -2179,7 +1044,7 @@ to ensure they are compliant with RFC1952. This option is enabled by default. -If C<Strict> is enabled the following behavior will be policed: +If C<Strict> is enabled the following behaviour will be policed: =over 5 @@ -2211,7 +1076,7 @@ value 0x00. =back -When C<Strict> is disabled the following behavior will be policed: +When C<Strict> is disabled the following behaviour will be policed: =over 5 @@ -2261,7 +1126,7 @@ Usage is print $z $data Compresses and outputs the contents of the C<$data> parameter. This -has the same behavior as the C<print> built-in. +has the same behaviour as the C<print> built-in. Returns true if successful. @@ -2424,13 +1289,24 @@ underlying file will also be closed. -=head2 newStream +=head2 newStream([OPTS]) Usage is - $z->newStream + $z->newStream( [OPTS] ) -TODO +Closes the current compressed data stream and starts a new one. + +OPTS consists of the following sub-set of the the options that are +available when creating the C<$z> object, + +=over 5 + +=item * Level + +=item * TODO + +=back =head2 deflateParams @@ -2540,7 +1416,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005 Paul Marquess. All rights reserved. +Copyright (c) 2005-2006 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/Compress/Zlib/lib/IO/Compress/RawDeflate.pm b/ext/Compress/Zlib/lib/IO/Compress/RawDeflate.pm index 096f5e626b..e100ee2b95 100644 --- a/ext/Compress/Zlib/lib/IO/Compress/RawDeflate.pm +++ b/ext/Compress/Zlib/lib/IO/Compress/RawDeflate.pm @@ -4,34 +4,243 @@ package IO::Compress::RawDeflate ; # use strict ; use warnings; -use IO::Uncompress::RawInflate; + + +use IO::Compress::Base; +use CompressPlugin::Deflate ; require Exporter ; +use Compress::Zlib::Common qw(:Status createSelfTiedObject); -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $RawDeflateError); -$VERSION = '2.000_05'; +our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError); + +$VERSION = '2.000_07'; $RawDeflateError = ''; -@ISA = qw(Exporter IO::BaseDeflate); +@ISA = qw(Exporter IO::Compress::Base); @EXPORT_OK = qw( $RawDeflateError rawdeflate ) ; -%EXPORT_TAGS = %IO::BaseDeflate::EXPORT_TAGS ; push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; -Exporter::export_ok_tags('all'); +%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 $pkg = shift ; - return IO::BaseDeflate::new($pkg, 'rfc1951', undef, \$RawDeflateError, @_); + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$RawDeflateError); + + return $obj->_create(undef, @_); } sub rawdeflate { - return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1951', \$RawDeflateError, @_); + 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 ; + + #return CompressPlugin::Deflate::mkCompObject($self, $class, $got) + my ($obj, $errstr, $errno) = CompressPlugin::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 Compress::Zlib::ParseParameters; + use Compress::Zlib 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_32bit} = + *$self->{BytesWritten} = *$inf->{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__ @@ -61,7 +270,7 @@ IO::Compress::RawDeflate - Perl interface to write RFC 1951 files/buffers $z->seek($position, $whence); $z->binmode(); $z->fileno(); - $z->newStream(); + $z->newStream( [OPTS] ); $z->deflateParams(); $z->close() ; @@ -117,24 +326,25 @@ 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. +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"; - rawdeflate \%hash [,OPTS] - or die "rawdeflate failed: $RawDeflateError\n"; + The functional interface needs Perl5.005 or better. =head2 rawdeflate $input => $output [, OPTS] -If the first parameter is not a hash reference C<rawdeflate> expects -at least two parameters, C<$input> and C<$output>. + +C<rawdeflate> expects at least two parameters, C<$input> and C<$output>. =head3 The C<$input> parameter @@ -164,13 +374,15 @@ from C<$$input>. =item An array reference -If C<$input> is an array reference, the input data will be read from each -element of the array in turn. The action taken by C<rawdeflate> with -each element of the array will depend on the type of data stored -in it. You can mix and match any of the types defined in this list, -excluding other array or hash references. +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 data types before any data is compressed. +contains valid filenames before any data is compressed. + + =item An Input FileGlob string @@ -198,36 +410,28 @@ compressed data. This parameter can take one of these forms. =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. +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. +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>. - +If C<$output> is a scalar reference, the compressed data will be +stored in C<$$output>. -=item A Hash Reference - -If C<$output> is a hash reference, the compressed data will be written -to C<$output{$input}> as a scalar reference. - -When C<$output> is a hash reference, C<$input> must be either a filename or -list of filenames. Anything else is an error. =item An Array Reference -If C<$output> is an array reference, the compressed data will be pushed -onto the array. +If C<$output> is an array reference, the compressed data will be +pushed onto the array. =item An Output FileGlob @@ -242,60 +446,13 @@ string. Anything else is an error. If the C<$output> parameter is any other type, C<undef> will be returned. -=head2 rawdeflate \%hash [, OPTS] - -If the first parameter is a hash reference, C<\%hash>, this will be used to -define both the source of uncompressed data and to control where the -compressed data is output. Each key/value pair in the hash defines a -mapping between an input filename, stored in the key, and an output -file/buffer, stored in the value. Although the input can only be a filename, -there is more flexibility to control the destination of the compressed -data. This is determined by the type of the value. Valid types are - -=over 5 - -=item undef - -If the value is C<undef> the compressed data will be written to the -value as a scalar reference. - -=item A filename - -If the value 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 value 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 the value is a scalar reference, the compressed data will be stored -in the buffer that is referenced by the scalar. - - -=item A Hash Reference - -If the value is a hash reference, the compressed data will be written -to C<$hash{$input}> as a scalar reference. - -=item An Array Reference - -If C<$output> is an array reference, the compressed data will be pushed -onto the array. - -=back -Any other type is a error. =head2 Notes When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the compressed input files/buffers will all be stored in -C<$output> as a single compressed stream. +file/buffer the compressed input files/buffers will all be stored +in C<$output> as a single compressed stream. @@ -309,8 +466,8 @@ L</"Constructor Options"> section below. =item AutoClose =E<gt> 0|1 -This option applies to any input or output data streams to C<rawdeflate> -that are filehandles. +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 @@ -320,6 +477,16 @@ This parameter defaults to 0. +=item BinModeIn =E<gt> 0|1 + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + + + + + =item -Append =E<gt> 0|1 TODO @@ -440,9 +607,9 @@ C<OPTS> is any combination of the following options: =item -AutoClose =E<gt> 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. +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. @@ -450,27 +617,27 @@ This parameter defaults to 0. Opens C<$output> in append mode. -The behaviour of this option is dependant on the type of C<$output>. +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. +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. +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. +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 @@ -484,8 +651,8 @@ 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. +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1951 data stream. @@ -495,8 +662,9 @@ There are a number of other limitations with the C<Merge> option: =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. +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 @@ -567,7 +735,7 @@ Usage is print $z $data Compresses and outputs the contents of the C<$data> parameter. This -has the same behavior as the C<print> built-in. +has the same behaviour as the C<print> built-in. Returns true if successful. @@ -730,13 +898,24 @@ underlying file will also be closed. -=head2 newStream +=head2 newStream([OPTS]) Usage is - $z->newStream + $z->newStream( [OPTS] ) -TODO +Closes the current compressed data stream and starts a new one. + +OPTS consists of the following sub-set of the the options that are +available when creating the C<$z> object, + +=over 5 + +=item * Level + +=item * TODO + +=back =head2 deflateParams @@ -846,7 +1025,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005 Paul Marquess. All rights reserved. +Copyright (c) 2005-2006 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/Compress/Zlib/lib/IO/Compress/Zip.pm b/ext/Compress/Zlib/lib/IO/Compress/Zip.pm new file mode 100644 index 0000000000..87b61f49df --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Compress/Zip.pm @@ -0,0 +1,290 @@ +package IO::Compress::Zip ; + +use strict ; +use warnings; + +use Compress::Zlib::Common qw(createSelfTiedObject); +use CompressPlugin::Deflate; +use CompressPlugin::Identity; +use IO::Compress::RawDeflate; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $ZipError); + +$VERSION = '2.000_04'; +$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 ; +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}{Store}) { + #return CompressPlugin::Deflate::mkCompObject($self, $class, $got) + ($obj, $errstr, $errno) = CompressPlugin::Identity::mkCompObject( + $got->value('CRC32'), + $got->value('Adler32'), + $got->value('Level'), + $got->value('Strategy') + ); + } + else { + #return CompressPlugin::Deflate::mkCompObject($self, $class, $got) + ($obj, $errstr, $errno) = CompressPlugin::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; + my $param = shift ; + + my $filename = ''; + $filename = $param->value('Name') || ''; + + my $comment = ''; + $comment = $param->value('Comment') || ''; + + my $extract = $param->value('OS_Code') << 8 + 20 ; + my $hdr = ''; + + my $time = _unixToDosTime($param->value('Time')); + *$self->{ZipData}{StartOffset} = *$self->{ZipData}{Offset} ; + + my $strm = *$self->{ZipData}{Stream} ? 8 : 0 ; + my $method = *$self->{ZipData}{Store} ? 0 : 8 ; + + $hdr .= pack "V", 0x04034b50 ; # signature + $hdr .= pack 'v', $extract ; # extract Version & OS + $hdr .= pack 'v', $strm ; # 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', 0 ; # compressed length - 0 when streaming + $hdr .= pack 'V', 0 ; # uncompressed length - 0 when streaming + $hdr .= pack 'v', length $filename ; # filename length + $hdr .= pack 'v', 0 ; # extra length + + $hdr .= $filename ; + + + my $ctl = ''; + + $ctl .= pack "V", 0x02014b50 ; # signature + $ctl .= pack 'v', $extract ; # version made by + $ctl .= pack 'v', $extract ; # extract Version + $ctl .= pack 'v', $strm ; # 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', 0 ; # compressed length + $ctl .= pack 'V', 0 ; # uncompressed length + $ctl .= pack 'v', length $filename ; # filename length + $ctl .= pack 'v', 0 ; # extra length + $ctl .= pack 'v', length $comment ; # file comment length + $ctl .= pack 'v', 0 ; # disk number start + $ctl .= pack 'v', 0 ; # internal file attributes + $ctl .= pack 'V', 0 ; # external file attributes + $ctl .= pack 'V', *$self->{ZipData}{Offset} ; # offset to local header + + $ctl .= $filename ; + #$ctl .= $extra ; + $ctl .= $comment ; + + *$self->{ZipData}{Offset} += length $hdr ; + + *$self->{ZipData}{CentralHeader} = $ctl; + + return $hdr; +} + +sub mkTrailer +{ + my $self = shift ; + + my $crc32 = *$self->{Compress}->crc32(); + my $compressedBytes = *$self->{Compress}->compressedBytes(); + my $uncompressedBytes = *$self->{Compress}->uncompressedBytes(); + + my $data ; + $data .= pack "V", $crc32 ; # CRC32 + $data .= pack "V", $compressedBytes ; # Compressed Size + $data .= pack "V", $uncompressedBytes; # Uncompressed Size + + my $hdr = ''; + + if (*$self->{ZipData}{Stream}) { + $hdr = pack "V", 0x08074b50 ; # signature + $hdr .= $data ; + } + else { + $self->writeAt(*$self->{ZipData}{StartOffset} + 14, $data) + or return undef; + } + + my $ctl = *$self->{ZipData}{CentralHeader} ; + substr($ctl, 16, 12) = $data ; + #substr($ctl, 16, 4) = pack "V", $crc32 ; # CRC32 + #substr($ctl, 20, 4) = pack "V", $compressedBytes ; # Compressed Size + #substr($ctl, 24, 4) = pack "V", $uncompressedBytes ; # Uncompressed Size + + *$self->{ZipData}{Offset} += length($hdr) + $compressedBytes; + push @{ *$self->{ZipData}{CentralDir} }, $ctl ; + + return $hdr; +} + +sub mkFinalTrailer +{ + my $self = shift ; + + my $entries = @{ *$self->{ZipData}{CentralDir} }; + my $cd = join '', @{ *$self->{ZipData}{CentralDir} }; + + my $ecd = ''; + $ecd .= pack "V", 0x06054b50 ; # signature + $ecd .= pack 'v', 0 ; # number of disk + $ecd .= pack 'v', 0 ; # number if 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', length $cd ; # size of central dir + $ecd .= pack 'V', *$self->{ZipData}{Offset} ; # offset to start central dir + $ecd .= pack 'v', 0 ; # zipfile comment length + #$ecd .= $comment; + + return $cd . $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) ; + } + + *$self->{ZipData}{Stream} = $got->value('Stream'); + *$self->{ZipData}{Store} = $got->value('Store'); + *$self->{ZipData}{StartOffset} = *$self->{ZipData}{Offset} = 0; + + return 1 ; +} + +#sub newHeader +#{ +# my $self = shift ; +# +# return $self->mkHeader(*$self->{Got}); +#} + +sub getExtraParams +{ + my $self = shift ; + + use Compress::Zlib::ParseParameters; + use Compress::Zlib qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); + + + return ( + # zlib behaviour + $self->getZlibParams(), + + 'Stream' => [1, 1, Parse_boolean, 1], + 'Store' => [0, 1, Parse_boolean, 0], + +# # Zip header fields +# 'Minimal' => [0, 1, Parse_boolean, 0], + 'Comment' => [0, 1, Parse_any, undef], + 'ZipComment'=> [0, 1, Parse_any, undef], + 'Name' => [0, 1, Parse_any, undef], + 'Time' => [0, 1, Parse_any, undef], + 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Zlib::gzip_os_code], + +# 'TextFlag' => [0, 1, Parse_boolean, 0], +# 'ExtraField'=> [0, 1, Parse_string, undef], + ); +} + +sub getInverseClass +{ + return ('IO::Uncompress::Unzip', + \$IO::Uncompress::Unzip::UnzipError); +} + +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') ; + + +} + +# 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__ diff --git a/ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm b/ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm index 0ec9bd2ee5..12f592be00 100644 --- a/ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm +++ b/ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm @@ -4,35 +4,117 @@ package IO::Uncompress::AnyInflate ; use strict; use warnings; + +use Compress::Zlib::Common qw(createSelfTiedObject); + +use UncompressPlugin::Inflate (); +#use UncompressPlugin::Bunzip2 (); + + +#use IO::Uncompress::Base ; use IO::Uncompress::Gunzip ; +use IO::Uncompress::Inflate ; +use IO::Uncompress::RawInflate ; +use IO::Uncompress::Unzip ; +#use IO::Uncompress::Bunzip2 ; +#use IO::Uncompress::UnLzop ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; $AnyInflateError = ''; -@ISA = qw(Exporter IO::BaseInflate); +@ISA = qw( Exporter IO::Uncompress::Base ); @EXPORT_OK = qw( $AnyInflateError anyinflate ) ; -%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ; +%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 $pkg = shift ; - return IO::BaseInflate::new($pkg, 'any', undef, \$AnyInflateError, 0, @_); + my $class = shift ; + my $obj = createSelfTiedObject($class, \$AnyInflateError); + $obj->_create(undef, 0, @_); } sub anyinflate { - return IO::BaseInflate::_inf(__PACKAGE__, 'any', \$AnyInflateError, @_) ; + my $obj = createSelfTiedObject(undef, \$AnyInflateError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + return (); +} + +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) = UncompressPlugin::Inflate::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + my $magic = $self->ckMagic( qw( RawInflate Inflate Gunzip Unzip ) ); + + 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 ; @@ -108,34 +190,35 @@ B<WARNING -- This is a Beta release>. -This module provides a Perl interface that allows the reading of files/buffers -that conform to RFC's 1950, 1951 and 1952. +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC's 1950, 1951 and 1952. -The module will auto-detect which, if any, of the three supported compression -formats is being used. +The module will auto-detect which, if any, of the three 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. +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"; - anyinflate \%hash [,OPTS] - or die "anyinflate failed: $AnyInflateError\n"; + The functional interface needs Perl5.005 or better. =head2 anyinflate $input => $output [, OPTS] -If the first parameter is not a hash reference C<anyinflate> expects -at least two parameters, C<$input> and C<$output>. + +C<anyinflate> expects at least two parameters, C<$input> and C<$output>. =head3 The C<$input> parameter @@ -165,13 +248,15 @@ from C<$$input>. =item An array reference -If C<$input> is an array reference, the input data will be read from each -element of the array in turn. The action taken by C<anyinflate> with -each element of the array will depend on the type of data stored -in it. You can mix and match any of the types defined in this list, -excluding other array or hash references. +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 data types before any data is uncompressed. +contains valid filenames before any data is uncompressed. + + =item An Input FileGlob string @@ -199,36 +284,28 @@ uncompressed data. This parameter can take one of these forms. =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. +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. +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 A Hash Reference - -If C<$output> is a hash reference, the uncompressed data will be written -to C<$output{$input}> as a scalar reference. +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. -When C<$output> is a hash reference, C<$input> must be either a filename or -list of filenames. Anything else is an error. =item An Array Reference -If C<$output> is an array reference, the uncompressed data will be pushed -onto the array. +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. =item An Output FileGlob @@ -243,60 +320,13 @@ string. Anything else is an error. If the C<$output> parameter is any other type, C<undef> will be returned. -=head2 anyinflate \%hash [, OPTS] -If the first parameter is a hash reference, C<\%hash>, this will be used to -define both the source of compressed data and to control where the -uncompressed data is output. Each key/value pair in the hash defines a -mapping between an input filename, stored in the key, and an output -file/buffer, stored in the value. Although the input can only be a filename, -there is more flexibility to control the destination of the uncompressed -data. This is determined by the type of the value. Valid types are - -=over 5 - -=item undef - -If the value is C<undef> the uncompressed data will be written to the -value as a scalar reference. - -=item A filename - -If the value 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 value 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 the value is a scalar reference, the uncompressed data will be stored -in the buffer that is referenced by the scalar. - - -=item A Hash Reference - -If the value is a hash reference, the uncompressed data will be written -to C<$hash{$input}> as a scalar reference. - -=item An Array Reference - -If C<$output> is an array reference, the uncompressed data will be pushed -onto the array. - -=back - -Any other type is a error. =head2 Notes When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the uncompressed input files/buffers will all be stored in -C<$output> as a single uncompressed stream. +file/buffer the uncompressed input files/buffers will all be stored +in C<$output> as a single uncompressed stream. @@ -310,8 +340,8 @@ L</"Constructor Options"> section below. =item AutoClose =E<gt> 0|1 -This option applies to any input or output data streams to C<anyinflate> -that are filehandles. +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 @@ -321,10 +351,27 @@ This parameter defaults to 0. +=item BinModeOut =E<gt> 0|1 + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + + + + + =item -Append =E<gt> 0|1 TODO +=item -MultiStream =E<gt> 0|1 + +Creates a new stream after each file. + +Defaults to 1. + =back @@ -397,11 +444,11 @@ The format of the constructor for IO::Uncompress::AnyInflate is shown below 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 +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>; @@ -475,8 +522,9 @@ 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. +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 -Transparent =E<gt> 0|1 @@ -487,20 +535,21 @@ This option defaults to 1. =item -BlockSize =E<gt> $num -When reading the compressed input data, IO::Uncompress::AnyInflate will read it in blocks -of C<$num> bytes. +When reading the compressed input data, IO::Uncompress::AnyInflate will read it in +blocks of C<$num> bytes. This option defaults to 4096. =item -InputLength =E<gt> $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. +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 +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. @@ -511,11 +560,11 @@ This option defaults to off. 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 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. +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. @@ -524,8 +573,8 @@ Defaults to 0. 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. +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. @@ -569,8 +618,8 @@ If the gzip header contains a name field (FNAME) it consists solely of ISO =item 3 -If the gzip header contains a comment field (FCOMMENT) it consists solely of -ISO 8859-1 characters plus line-feed. +If the gzip header contains a comment field (FCOMMENT) it consists solely +of ISO 8859-1 characters plus line-feed. =item 4 @@ -588,8 +637,8 @@ 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. +The value of the ISIZE fields read must match the length of the +uncompressed data actually read from the file. =back @@ -626,12 +675,12 @@ Usage is 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. +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. +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. =head2 read @@ -645,13 +694,13 @@ Usage is 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. +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. +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. =head2 getline @@ -696,14 +745,12 @@ TODO Usage is - $hdr = $z->getHeaderInfo() - -TODO - - - - + $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). @@ -856,7 +903,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005 Paul Marquess. All rights reserved. +Copyright (c) 2005-2006 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/Compress/Zlib/lib/IO/Uncompress/AnyUncompress.pm b/ext/Compress/Zlib/lib/IO/Uncompress/AnyUncompress.pm new file mode 100644 index 0000000000..9e3708bd22 --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Uncompress/AnyUncompress.pm @@ -0,0 +1,156 @@ +package IO::Uncompress::AnyUncompress ; + +use strict; +use warnings; + +use Compress::Zlib::Common qw(createSelfTiedObject); + +#use IO::Uncompress::Base ; +use IO::Uncompress::Gunzip ; +use IO::Uncompress::Inflate ; +use IO::Uncompress::RawInflate ; +use IO::Uncompress::Unzip ; + +BEGIN +{ + eval { require UncompressPlugin::Bunzip2; import UncompressPlugin::Bunzip2 }; + eval { require UncompressPlugin::LZO; import UncompressPlugin::LZO }; + eval { require IO::Uncompress::Bunzip2; import IO::Uncompress::Bunzip2 }; + eval { require IO::Uncompress::UnLzop; import IO::Uncompress::UnLzop }; +} + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError); + +$VERSION = '2.000_05'; +$AnyUncompressError = ''; + +@ISA = qw( Exporter IO::Uncompress::Base ); +@EXPORT_OK = qw( $AnyUncompressError anyuncompress ) ; +%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, \$AnyUncompressError); + $obj->_create(undef, 0, @_); +} + +sub anyuncompress +{ + my $obj = createSelfTiedObject(undef, \$AnyUncompressError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + return (); +} + +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 ; + + # try zlib first + my ($obj, $errstr, $errno) = UncompressPlugin::Inflate::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + my $magic = $self->ckMagic( qw( RawInflate Inflate Gunzip Unzip ) ); + + if ($magic) { + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + return 1; + } + + #foreach my $type ( qw( Bunzip2 UnLzop ) ) { + if (defined $IO::Uncompress::Bunzip2::VERSION and + $magic = $self->ckMagic('Bunzip2')) { + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + my ($obj, $errstr, $errno) = UncompressPlugin::Bunzip2::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + return 1; + } + elsif (defined $IO::Uncompress::UnLzop::VERSION and + $magic = $self->ckMagic('UnLzop')) { + + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + my ($obj, $errstr, $errno) = UncompressPlugin::LZO::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + 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__ + + diff --git a/ext/Compress/Zlib/lib/IO/Uncompress/Base.pm b/ext/Compress/Zlib/lib/IO/Uncompress/Base.pm new file mode 100644 index 0000000000..db21ab0bfc --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Uncompress/Base.pm @@ -0,0 +1,1250 @@ + +package IO::Uncompress::Base ; + +use strict ; +use warnings; +use bytes; + +our ($VERSION, @EXPORT_OK, %EXPORT_TAGS); + +$VERSION = '2.000_05'; + +use constant G_EOF => 0 ; +use constant G_ERR => -1 ; + +use Compress::Zlib::Common ; +use Compress::Zlib::ParseParameters ; + +use IO::File ; +use Symbol; +use Scalar::Util qw(readonly); +use List::Util qw(min); +use Carp ; + +%EXPORT_TAGS = ( ); +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +#Exporter::export_ok_tags('all') ; + + +sub smartRead +{ + my $self = $_[0]; + my $out = $_[1]; + my $size = $_[2]; + $$out = "" ; + + my $offset = 0 ; + + + if ( length *$self->{Prime} ) { + #$$out = substr(*$self->{Prime}, 0, $size, '') ; + $$out = substr(*$self->{Prime}, 0, $size) ; + substr(*$self->{Prime}, 0, $size) = '' ; + if (length $$out == $size) { + #*$self->{InputLengthRemaining} -= length $$out; + return length $$out ; + } + $offset = length $$out ; + } + + my $get_size = $size - $offset ; + + if ( defined *$self->{InputLength} ) { + #*$self->{InputLengthRemaining} += length *$self->{Prime} ; + #*$self->{InputLengthRemaining} = *$self->{InputLength} + # if *$self->{InputLengthRemaining} > *$self->{InputLength}; + $get_size = min($get_size, *$self->{InputLengthRemaining}); + } + + if (defined *$self->{FH}) + { *$self->{FH}->read($$out, $get_size, $offset) } + elsif (defined *$self->{InputEvent}) { + my $got = 1 ; + while (length $$out < $size) { + last + if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0; + } + + if (length $$out > $size ) { + #*$self->{Prime} = substr($$out, $size, length($$out), ''); + *$self->{Prime} = substr($$out, $size, length($$out)); + substr($$out, $size, length($$out)) = ''; + } + + *$self->{EventEof} = 1 if $got <= 0 ; + } + else { + no warnings 'uninitialized'; + my $buf = *$self->{Buffer} ; + $$buf = '' unless defined $$buf ; + #$$out = '' unless defined $$out ; + substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size); + *$self->{BufferOffset} += length($$out) - $offset ; + } + + *$self->{InputLengthRemaining} -= length $$out; + + $self->saveStatus(length $$out < 0 ? STATUS_ERROR : 0) ; + + return length $$out; +} + +sub pushBack +{ + my $self = shift ; + + return if ! defined $_[0] || length $_[0] == 0 ; + + if (defined *$self->{FH} || defined *$self->{InputEvent} ) { + *$self->{Prime} = $_[0] . *$self->{Prime} ; + } + else { + my $len = length $_[0]; + + if($len > *$self->{BufferOffset}) { + *$self->{Prime} = substr($_[0], 0, $len - *$self->{BufferOffset}) . *$self->{Prime} ; + *$self->{InputLengthRemaining} = *$self->{InputLength}; + *$self->{BufferOffset} = 0 + } + else { + *$self->{InputLengthRemaining} += length($_[0]); + *$self->{BufferOffset} -= length($_[0]) ; + } + } +} + +sub smartSeek +{ + my $self = shift ; + my $offset = shift ; + my $truncate = shift; + #print "smartSeek to $offset\n"; + + # TODO -- need to take prime into account + if (defined *$self->{FH}) + { *$self->{FH}->seek($offset, SEEK_SET) } + else { + *$self->{BufferOffset} = $offset ; + substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = '' + if $truncate; + return 1; + } +} + +sub smartWrite +{ + my $self = shift ; + my $out_data = shift ; + + if (defined *$self->{FH}) { + # flush needed for 5.8.0 + defined *$self->{FH}->write($out_data, length $out_data) && + defined *$self->{FH}->flush() ; + } + else { + my $buf = *$self->{Buffer} ; + substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ; + *$self->{BufferOffset} += length($out_data) ; + return 1; + } +} + +sub smartReadExact +{ + return $_[0]->smartRead($_[1], $_[2]) == $_[2]; +} + +sub smartEof +{ + my ($self) = $_[0]; + + return 0 if length *$self->{Prime}; + + if (defined *$self->{FH}) + { *$self->{FH}->eof() } + elsif (defined *$self->{InputEvent}) + { *$self->{EventEof} } + else + { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) } +} + +sub clearError +{ + my $self = shift ; + + *$self->{ErrorNo} = 0 ; + ${ *$self->{Error} } = '' ; +} + +sub saveStatus +{ + my $self = shift ; + my $errno = shift() + 0 ; + #return $errno unless $errno || ! defined *$self->{ErrorNo}; + #return $errno unless $errno ; + + *$self->{ErrorNo} = $errno; + ${ *$self->{Error} } = '' ; + + return *$self->{ErrorNo} ; +} + + +sub saveErrorString +{ + my $self = shift ; + my $retval = shift ; + + #return $retval if ${ *$self->{Error} }; + + ${ *$self->{Error} } = shift ; + *$self->{ErrorNo} = shift() + 0 if @_ ; + + #warn "saveErrorString: " . ${ *$self->{Error} } . " " . *$self->{Error} . "\n" ; + return $retval; +} + +sub croakError +{ + my $self = shift ; + $self->saveErrorString(0, $_[0]); + croak $_[0]; +} + + +sub closeError +{ + my $self = shift ; + my $retval = shift ; + + my $errno = *$self->{ErrorNo}; + my $error = ${ *$self->{Error} }; + + $self->close(); + + *$self->{ErrorNo} = $errno ; + ${ *$self->{Error} } = $error ; + + return $retval; +} + +sub error +{ + my $self = shift ; + return ${ *$self->{Error} } ; +} + +sub errorNo +{ + my $self = shift ; + return *$self->{ErrorNo}; +} + +sub HeaderError +{ + my ($self) = shift; + return $self->saveErrorString(undef, "Header Error: $_[0]", STATUS_ERROR); +} + +sub TrailerError +{ + my ($self) = shift; + return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", STATUS_ERROR); +} + +sub TruncatedHeader +{ + my ($self) = shift; + return $self->HeaderError("Truncated in $_[0] Section"); +} + +sub checkParams +{ + my $self = shift ; + my $class = shift ; + + my $got = shift || Compress::Zlib::ParseParameters::new(); + + my $Valid = { + 'BlockSize' => [1, 1, Parse_unsigned, 16 * 1024], + 'AutoClose' => [1, 1, Parse_boolean, 0], + 'Strict' => [1, 1, Parse_boolean, 0], + #'Lax' => [1, 1, Parse_boolean, 1], + 'Append' => [1, 1, Parse_boolean, 0], + 'Prime' => [1, 1, Parse_any, undef], + 'MultiStream' => [1, 1, Parse_boolean, 0], + 'Transparent' => [1, 1, Parse_any, 1], + 'Scan' => [1, 1, Parse_boolean, 0], + 'InputLength' => [1, 1, Parse_unsigned, undef], + 'BinModeOut' => [1, 1, Parse_boolean, 0], + + $self->getExtraParams(), + + + #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0, + # ContinueAfterEof + } ; + + + $got->parse($Valid, @_ ) + or $self->croakError("${class}: $got->{Error}") ; + + + return $got; +} + +sub _create +{ + my $obj = shift; + my $got = shift; + my $append_mode = shift ; + + my $class = ref $obj; + $obj->croakError("$class: Missing Input parameter") + if ! @_ && ! $got ; + + my $inValue = shift ; + + if (! $got) + { + $got = $obj->checkParams($class, undef, @_) + or return undef ; + } + + my $inType = whatIsInput($inValue, 1); + + $obj->ckInputParam($class, $inValue, 1) + or return undef ; + + *$obj->{InNew} = 1; + + $obj->ckParams($got) + or $obj->croakError("${class}: $obj->{Error}"); + + if ($inType eq 'buffer' || $inType eq 'code') { + *$obj->{Buffer} = $inValue ; + *$obj->{InputEvent} = $inValue + if $inType eq 'code' ; + } + else { + if ($inType eq 'handle') { + *$obj->{FH} = $inValue ; + *$obj->{Handle} = 1 ; + # Need to rewind for Scan + #seek(*$obj->{FH}, 0, SEEK_SET) if $got->value('Scan'); + *$obj->{FH}->seek(0, SEEK_SET) if $got->value('Scan'); + } + else { + my $mode = '<'; + $mode = '+<' if $got->value('Scan'); + *$obj->{StdIO} = ($inValue eq '-'); + *$obj->{FH} = new IO::File "$mode $inValue" + or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ; + *$obj->{LineNo} = 0; + } + + setBinModeInput(*$obj->{FH}) ; + + my $buff = "" ; + *$obj->{Buffer} = \$buff ; + } + + + *$obj->{InputLength} = $got->parsed('InputLength') + ? $got->value('InputLength') + : undef ; + *$obj->{InputLengthRemaining} = $got->value('InputLength'); + *$obj->{BufferOffset} = 0 ; + *$obj->{AutoClose} = $got->value('AutoClose'); + *$obj->{Strict} = $got->value('Strict'); + #*$obj->{Strict} = ! $got->value('Lax'); + *$obj->{BlockSize} = $got->value('BlockSize'); + *$obj->{Append} = $got->value('Append'); + *$obj->{AppendOutput} = $append_mode || $got->value('Append'); + *$obj->{Transparent} = $got->value('Transparent'); + *$obj->{MultiStream} = $got->value('MultiStream'); + + # TODO - move these two into RawDeflate + *$obj->{Scan} = $got->value('Scan'); + *$obj->{ParseExtra} = $got->value('ParseExtra') + || $got->value('Strict') ; + #|| ! $got->value('Lax') ; + *$obj->{Type} = ''; + *$obj->{Prime} = $got->value('Prime') || '' ; + *$obj->{Pending} = ''; + *$obj->{Plain} = 0; + *$obj->{PlainBytesRead} = 0; + *$obj->{InflatedBytesRead} = 0; + *$obj->{UnCompSize_32bit} = 0; + *$obj->{TotalInflatedBytesRead} = 0; + *$obj->{NewStream} = 0 ; + *$obj->{EventEof} = 0 ; + *$obj->{ClassName} = $class ; + *$obj->{Params} = $got ; + + my $status = $obj->mkUncomp($class, $got); + + return undef + unless defined $status; + + if ( ! $status) { + return undef + unless *$obj->{Transparent}; + + $obj->clearError(); + *$obj->{Type} = 'plain'; + *$obj->{Plain} = 1; + #$status = $obj->mkIdentityUncomp($class, $got); + $obj->pushBack(*$obj->{HeaderPending}) ; + } + + push @{ *$obj->{InfoList} }, *$obj->{Info} ; + + $obj->saveStatus(0) ; + *$obj->{InNew} = 0; + *$obj->{Closed} = 0; + + return $obj; +} + +sub ckInputParam +{ + my $self = shift ; + my $from = shift ; + my $inType = whatIsInput($_[0], $_[1]); + + $self->croakError("$from: input parameter not a filename, filehandle, array ref or scalar ref") + if ! $inType ; + + if ($inType eq 'filename' ) + { + $self->croakError("$from: input filename is undef or null string") + if ! defined $_[0] || $_[0] eq '' ; + + if ($_[0] ne '-' && ! -e $_[0] ) + { + return $self->saveErrorString(undef, + "input file '$_[0]' does not exist", STATUS_ERROR); + } + } + + return 1; +} + + +sub _inf +{ + my $obj = shift ; + + my $class = (caller)[0] ; + my $name = (caller(1))[3] ; + + $obj->croakError("$name: expected at least 1 parameters\n") + unless @_ >= 1 ; + + my $input = shift ; + my $haveOut = @_ ; + my $output = shift ; + + + my $x = new Validator($class, *$obj->{Error}, $name, $input, $output) + or return undef ; + + push @_, $output if $haveOut && $x->{Hash}; + + my $got = $obj->checkParams($name, undef, @_) + or return undef ; + + $x->{Got} = $got ; + + if ($x->{Hash}) + { + while (my($k, $v) = each %$input) + { + $v = \$input->{$k} + unless defined $v ; + + $obj->_singleTarget($x, 1, $k, $v, @_) + or return undef ; + } + + return keys %$input ; + } + + if ($x->{GlobMap}) + { + $x->{oneInput} = 1 ; + foreach my $pair (@{ $x->{Pairs} }) + { + my ($from, $to) = @$pair ; + $obj->_singleTarget($x, 1, $from, $to, @_) + or return undef ; + } + + return scalar @{ $x->{Pairs} } ; + } + + #if ($x->{outType} eq 'array' || $x->{outType} eq 'hash') + if (! $x->{oneOutput} ) + { + my $inFile = ($x->{inType} eq 'filenames' + || $x->{inType} eq 'filename'); + + $x->{inType} = $inFile ? 'filename' : 'buffer'; + my $ot = $x->{outType} ; + $x->{outType} = 'buffer'; + + foreach my $in ($x->{oneInput} ? $input : @$input) + { + my $out ; + $x->{oneInput} = 1 ; + + $obj->_singleTarget($x, $inFile, $in, \$out, @_) + or return undef ; + + if ($ot eq 'array') + { push @$output, \$out } + else + { $output->{$in} = \$out } + } + + return 1 ; + } + + # finally the 1 to 1 and n to 1 + return $obj->_singleTarget($x, 1, $input, $output, @_); + + croak "should not be here" ; +} + +sub retErr +{ + my $x = shift ; + my $string = shift ; + + ${ $x->{Error} } = $string ; + + return undef ; +} + +sub _singleTarget +{ + my $self = shift ; + my $x = shift ; + my $inputIsFilename = shift; + my $input = shift; + my $output = shift; + + $x->{buff} = '' ; + + my $fh ; + if ($x->{outType} eq 'filename') { + my $mode = '>' ; + $mode = '>>' + if $x->{Got}->value('Append') ; + $x->{fh} = new IO::File "$mode $output" + or return retErr($x, "cannot open file '$output': $!") ; + binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut'); + + } + + elsif ($x->{outType} eq 'handle') { + $x->{fh} = $output; + binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut'); + if ($x->{Got}->value('Append')) { + seek($x->{fh}, 0, SEEK_END) + or return retErr($x, "Cannot seek to end of output filehandle: $!") ; + } + } + + + elsif ($x->{outType} eq 'buffer' ) + { + $$output = '' + unless $x->{Got}->value('Append'); + $x->{buff} = $output ; + } + + if ($x->{oneInput}) + { + defined $self->_rd2($x, $input, $inputIsFilename) + or return undef; + } + else + { + my $inputIsFilename = ($x->{inType} ne 'array'); + + for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) + { + defined $self->_rd2($x, $element, $inputIsFilename) + or return undef ; + } + } + + + if ( ($x->{outType} eq 'filename' && $output ne '-') || + ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) { + $x->{fh}->close() + or return retErr($x, $!); + #or return $gunzip->saveErrorString(undef, $!, $!); + delete $x->{fh}; + } + + return 1 ; +} + +sub _rd2 +{ + my $self = shift ; + my $x = shift ; + my $input = shift; + my $inputIsFilename = shift; + + my $z = createSelfTiedObject($x->{Class}, *$self->{Error}); + + $z->_create($x->{Got}, 1, $input, @_) + or return undef ; + + my $status ; + my $fh = $x->{fh}; + + while (($status = $z->read($x->{buff})) > 0) { + if ($fh) { + print $fh $x->{buff} + or return $z->saveErrorString(undef, "Error writing to output file: $!", $!); + $x->{buff} = '' ; + } + } + + return $z->closeError(undef) + if $status < 0 ; + + $z->close() + or return undef ; + + return 1 ; +} + +sub TIEHANDLE +{ + return $_[0] if ref($_[0]); + die "OOPS\n" ; + +} + +sub UNTIE +{ + my $self = shift ; +} + + +sub getHeaderInfo +{ + my $self = shift ; + wantarray ? @{ *$self->{InfoList} } : *$self->{Info}; +} + +sub readBlock +{ + my $self = shift ; + my $buff = shift ; + my $size = shift ; + + if (defined *$self->{CompressedInputLength}) { + if (*$self->{CompressedInputLengthRemaining} == 0) { + delete *$self->{CompressedInputLength}; + #$$buff = ''; + return STATUS_OK ; + } + $size = min($size, *$self->{CompressedInputLengthRemaining} ); + *$self->{CompressedInputLengthRemaining} -= $size ; + } + + my $status = $self->smartRead($buff, $size) ; + return $self->saveErrorString(STATUS_ERROR, "Error Reading Data") + if $status < 0 ; + + if ($status == 0 ) { + *$self->{Closed} = 1 ; + *$self->{EndStream} = 1 ; + return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR); + } + + return STATUS_OK; + +} + +sub postBlockChk +{ + return STATUS_OK; +} + +sub _raw_read +{ + # return codes + # >0 - ok, number of bytes read + # =0 - ok, eof + # <0 - not ok + + my $self = shift ; + + return G_EOF if *$self->{Closed} ; + #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; + return G_EOF if *$self->{EndStream} ; + + my $buffer = shift ; + my $scan_mode = shift ; + + if (*$self->{Plain}) { + my $tmp_buff ; + my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ; + + return $self->saveErrorString(G_ERR, "Error reading data: $!", $!) + if $len < 0 ; + + if ($len == 0 ) { + *$self->{EndStream} = 1 ; + } + else { + *$self->{PlainBytesRead} += $len ; + $$buffer .= $tmp_buff; + } + + return $len ; + } + + if (*$self->{NewStream}) { + + *$self->{NewStream} = 0 ; + *$self->{EndStream} = 0 ; + *$self->{Uncomp}->reset(); + + return G_ERR + unless my $magic = $self->ckMagic(); + *$self->{Info} = $self->readHeader($magic); + + return G_ERR unless defined *$self->{Info} ; + + push @{ *$self->{InfoList} }, *$self->{Info} ; + + # For the headers that actually uncompressed data, put the + # uncompressed data into the output buffer. + $$buffer .= *$self->{Pending} ; + my $len = length *$self->{Pending} ; + *$self->{Pending} = ''; + return $len; + } + + my $temp_buf ; + my $outSize = 0; + my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ; + return G_ERR + if $status == STATUS_ERROR ; + + my $buf_len = 0; + if ($status == STATUS_OK) { + my $before_len = defined $$buffer ? length $$buffer : 0 ; + $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer, + (defined *$self->{CompressedInputLength} && + *$self->{CompressedInputLengthRemaining} <= 0) || + $self->smartEof(), $outSize); + + return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo}) + if $self->saveStatus($status) == STATUS_ERROR; + + $self->postBlockChk($buffer) == STATUS_OK + or return G_ERR; + + #$buf_len = *$self->{Uncomp}->count(); + $buf_len = length($$buffer) - $before_len; + + + *$self->{InflatedBytesRead} += $buf_len ; + *$self->{TotalInflatedBytesRead} += $buf_len ; + my $rest = 0xFFFFFFFF - *$self->{UnCompSize_32bit} ; + if ($buf_len > $rest) { + *$self->{UnCompSize_32bit} = $buf_len - $rest - 1; + } + else { + *$self->{UnCompSize_32bit} += $buf_len ; + } + } + + if ($status == STATUS_ENDSTREAM) { + + *$self->{EndStream} = 1 ; + $self->pushBack($temp_buf) ; + $temp_buf = ''; + + my $trailer; + if (*$self->{Info}{TrailerLength}) + { + my $trailer_size = *$self->{Info}{TrailerLength} ; + + my $got = $self->smartRead(\$trailer, $trailer_size) ; + if ($got != $trailer_size) { + return $self->TrailerError("trailer truncated. Expected " . + "$trailer_size bytes, got $got") + if *$self->{Strict}; + $self->pushBack($trailer) ; + } + } + + $self->chkTrailer($trailer) == G_ERR + and return G_ERR; + + if (*$self->{MultiStream} && ! $self->smartEof()) { + #&& (length $temp_buf || ! $self->smartEof())){ + *$self->{NewStream} = 1 ; + *$self->{EndStream} = 0 ; + return $buf_len ; + } + + } + + + # return the number of uncompressed bytes read + return $buf_len ; +} + +#sub isEndStream +#{ +# my $self = shift ; +# return *$self->{NewStream} || +# *$self->{EndStream} ; +#} + +sub streamCount +{ + my $self = shift ; + return 1 if ! defined *$self->{InfoList}; + return scalar @{ *$self->{InfoList} } ; +} + +sub read +{ + # return codes + # >0 - ok, number of bytes read + # =0 - ok, eof + # <0 - not ok + + my $self = shift ; + + return G_EOF if *$self->{Closed} ; + return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; + + my $buffer ; + + #$self->croakError(*$self->{ClassName} . + # "::read: buffer parameter is read-only") + # if Compress::Zlib::_readonly_ref($_[0]); + + if (ref $_[0] ) { + $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only") + if readonly(${ $_[0] }); + + $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" ) + unless ref $_[0] eq 'SCALAR' ; + $buffer = $_[0] ; + } + else { + $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only") + if readonly($_[0]); + + $buffer = \$_[0] ; + } + + my $length = $_[1] ; + my $offset = $_[2] || 0; + + # the core read will return 0 if asked for 0 bytes + return 0 if defined $length && $length == 0 ; + + $length = $length || 0; + + $self->croakError(*$self->{ClassName} . "::read: length parameter is negative") + if $length < 0 ; + + $$buffer = '' unless *$self->{AppendOutput} || $offset ; + + # Short-circuit if this is a simple read, with no length + # or offset specified. + unless ( $length || $offset) { + if (length *$self->{Pending}) { + $$buffer .= *$self->{Pending} ; + my $len = length *$self->{Pending}; + *$self->{Pending} = '' ; + return $len ; + } + else { + my $len = 0; + $len = $self->_raw_read($buffer) + while ! *$self->{EndStream} && $len == 0 ; + return $len ; + } + } + + # Need to jump through more hoops - either length or offset + # or both are specified. + my $out_buffer = \*$self->{Pending} ; + + while (! *$self->{EndStream} && length($$out_buffer) < $length) + { + my $buf_len = $self->_raw_read($out_buffer); + return $buf_len + if $buf_len < 0 ; + } + + $length = length $$out_buffer + if length($$out_buffer) < $length ; + + if ($offset) { + $$buffer .= "\x00" x ($offset - length($$buffer)) + if $offset > length($$buffer) ; + #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ; + substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ; + substr($$out_buffer, 0, $length) = '' ; + } + else { + #$$buffer .= substr($$out_buffer, 0, $length, '') ; + $$buffer .= substr($$out_buffer, 0, $length) ; + substr($$out_buffer, 0, $length) = '' ; + } + + return $length ; +} + +sub _getline +{ + my $self = shift ; + + # Slurp Mode + if ( ! defined $/ ) { + my $data ; + 1 while $self->read($data) > 0 ; + return \$data ; + } + + # Paragraph Mode + if ( ! length $/ ) { + my $paragraph ; + while ($self->read($paragraph) > 0 ) { + if ($paragraph =~ s/^(.*?\n\n+)//s) { + *$self->{Pending} = $paragraph ; + my $par = $1 ; + return \$par ; + } + } + return \$paragraph; + } + + # Line Mode + { + my $line ; + my $endl = quotemeta($/); # quote in case $/ contains RE meta chars + while ($self->read($line) > 0 ) { + if ($line =~ s/^(.*?$endl)//s) { + *$self->{Pending} = $line ; + $. = ++ *$self->{LineNo} ; + my $l = $1 ; + return \$l ; + } + } + $. = ++ *$self->{LineNo} if defined($line); + return \$line; + } +} + +sub getline +{ + my $self = shift; + my $current_append = *$self->{AppendOutput} ; + *$self->{AppendOutput} = 1; + my $lineref = $self->_getline(); + *$self->{AppendOutput} = $current_append; + return $$lineref ; +} + +sub getlines +{ + my $self = shift; + $self->croakError(*$self->{ClassName} . + "::getlines: called in scalar context\n") unless wantarray; + my($line, @lines); + push(@lines, $line) while defined($line = $self->getline); + return @lines; +} + +sub READLINE +{ + goto &getlines if wantarray; + goto &getline; +} + +sub getc +{ + my $self = shift; + my $buf; + return $buf if $self->read($buf, 1); + return undef; +} + +sub ungetc +{ + my $self = shift; + *$self->{Pending} = "" unless defined *$self->{Pending} ; + *$self->{Pending} = $_[0] . *$self->{Pending} ; +} + + +sub trailingData +{ + my $self = shift ; + #return \"" if ! defined *$self->{Trailing} ; + #return \*$self->{Trailing} ; + + if (defined *$self->{FH} || defined *$self->{InputEvent} ) { + return *$self->{Prime} ; + } + else { + my $buf = *$self->{Buffer} ; + my $offset = *$self->{BufferOffset} ; + return substr($$buf, $offset, -1) ; + } +} + + +sub eof +{ + my $self = shift ; + + return (*$self->{Closed} || + (!length *$self->{Pending} + && ( $self->smartEof() || *$self->{EndStream}))) ; +} + +sub tell +{ + my $self = shift ; + + my $in ; + if (*$self->{Plain}) { + $in = *$self->{PlainBytesRead} ; + } + else { + $in = *$self->{TotalInflatedBytesRead} ; + } + + my $pending = length *$self->{Pending} ; + + return 0 if $pending > $in ; + return $in - $pending ; +} + +sub close +{ + # todo - what to do if close is called before the end of the gzip file + # do we remember any trailing data? + my $self = shift ; + + return 1 if *$self->{Closed} ; + + untie *$self + if $] >= 5.008 ; + + my $status = 1 ; + + if (defined *$self->{FH}) { + if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { + #if ( *$self->{AutoClose}) { + $! = 0 ; + $status = *$self->{FH}->close(); + return $self->saveErrorString(0, $!, $!) + if !*$self->{InNew} && $self->saveStatus($!) != 0 ; + } + delete *$self->{FH} ; + $! = 0 ; + } + *$self->{Closed} = 1 ; + + return 1; +} + +sub DESTROY +{ + my $self = shift ; + $self->close() ; +} + +sub seek +{ + my $self = shift ; + my $position = shift; + my $whence = shift ; + + my $here = $self->tell() ; + my $target = 0 ; + + + if ($whence == SEEK_SET) { + $target = $position ; + } + elsif ($whence == SEEK_CUR) { + $target = $here + $position ; + } + elsif ($whence == SEEK_END) { + $target = $position ; + $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ; + } + else { + $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter"); + } + + # short circuit if seeking to current offset + return 1 if $target == $here ; + + # Outlaw any attempt to seek backwards + $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards") + if $target < $here ; + + # Walk the file to the new offset + my $offset = $target - $here ; + + my $buffer ; + $self->read($buffer, $offset) == $offset + or return 0 ; + + return 1 ; +} + +sub fileno +{ + my $self = shift ; + return defined *$self->{FH} + ? fileno *$self->{FH} + : undef ; +} + +sub binmode +{ + 1; +# my $self = shift ; +# return defined *$self->{FH} +# ? binmode *$self->{FH} +# : 1 ; +} + +*BINMODE = \&binmode; +*SEEK = \&seek; +*READ = \&read; +*sysread = \&read; +*TELL = \&tell; +*EOF = \&eof; + +*FILENO = \&fileno; +*CLOSE = \&close; + +sub _notAvailable +{ + my $name = shift ; + #return sub { croak "$name Not Available" ; } ; + return sub { croak "$name Not Available: File opened only for intput" ; } ; +} + + +*print = _notAvailable('print'); +*PRINT = _notAvailable('print'); +*printf = _notAvailable('printf'); +*PRINTF = _notAvailable('printf'); +*write = _notAvailable('write'); +*WRITE = _notAvailable('write'); + +#*sysread = \&read; +#*syswrite = \&_notAvailable; + +#package IO::_infScan ; +# +#*_raw_read = \&IO::Uncompress::Base::_raw_read ; +#*smartRead = \&IO::Uncompress::Base::smartRead ; +#*smartWrite = \&IO::Uncompress::Base::smartWrite ; +#*smartSeek = \&IO::Uncompress::Base::smartSeek ; + +#sub mkIdentityUncomp +#{ +# my $self = shift ; +# my $class = shift ; +# my $got = shift ; +# +# *$self->{Uncomp} = UncompressPlugin::Identity::mkUncompObject($self, $class, $got) +# or return undef; +# +# return 1; +# +#} +# +# +#package UncompressPlugin::Identity; +# +#use strict ; +#use warnings; +# +#our ($VERSION, @ISA, @EXPORT); +# +#$VERSION = '2.000_05'; +# +#use constant STATUS_OK => 0; +#use constant STATUS_ENDSTREAM => 1; +#use constant STATUS_ERROR => 2; +# +#sub mkUncompObject +#{ +# my $class = shift ; +# +# bless { 'CompSize' => 0, +# 'UnCompSize' => 0, +# 'CRC32' => 0, +# 'ADLER32' => 0, +# }, __PACKAGE__ ; +#} +# +#sub uncompr +#{ +# my $self = shift ; +# my $from = shift ; +# my $to = shift ; +# my $eof = shift ; +# +# +# $self->{CompSize} += length $$from ; +# $self->{UnCompSize} = $self->{CompSize} ; +# +# $$to = $$from ; +# +# return STATUS_ENDSTREAM if $eof; +# return STATUS_OK ; +#} +# +#sub count +#{ +# my $self = shift ; +# return $self->{UnCompSize} ; +#} +# +#sub sync +#{ +# return STATUS_OK ; +#} +# +# +#sub reset +#{ +# return STATUS_OK ; +#} + + +package IO::Uncompress::Base ; + + +1 ; +__END__ + diff --git a/ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm b/ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm index 17003725bf..d6d3846c98 100644 --- a/ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm +++ b/ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm @@ -8,243 +8,108 @@ require 5.004 ; use strict ; use warnings; +use IO::Uncompress::RawInflate ; + +use Compress::Zlib qw( crc32 ) ; +use Compress::Zlib::Common qw(createSelfTiedObject); +use Compress::Gzip::Constants; + require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GunzipError); -@ISA = qw(Exporter IO::BaseInflate); +@ISA = qw( Exporter IO::Uncompress::RawInflate ); @EXPORT_OK = qw( $GunzipError gunzip ); -%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ; +%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ; push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; Exporter::export_ok_tags('all'); - $GunzipError = ''; -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; sub new { - my $pkg = shift ; - return IO::BaseInflate::new($pkg, 'rfc1952', undef, \$GunzipError, 0, @_); -} + my $class = shift ; + $GunzipError = ''; + my $obj = createSelfTiedObject($class, \$GunzipError); -sub gunzip -{ - return IO::BaseInflate::_inf(__PACKAGE__, 'rfc1952', \$GunzipError, @_) ; + $obj->_create(undef, 0, @_); } -package IO::BaseInflate ; - -use strict ; -use warnings; -use bytes; - -our ($VERSION, @EXPORT_OK, %EXPORT_TAGS); - -$VERSION = '2.000_03'; - -use Compress::Zlib 2 ; -use Compress::Zlib::Common ; -use Compress::Zlib::ParseParameters ; -use Compress::Gzip::Constants; -use Compress::Zlib::FileConstants; - -use IO::File ; -use Symbol; -use Scalar::Util qw(readonly); -use List::Util qw(min); -use Carp ; - -%EXPORT_TAGS = ( ); -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; -#Exporter::export_ok_tags('all') ; - - -use constant G_EOF => 0 ; -use constant G_ERR => -1 ; - -sub smartRead +sub gunzip { - my $self = $_[0]; - my $out = $_[1]; - my $size = $_[2]; - $$out = "" ; - - my $offset = 0 ; - - - if ( length *$self->{Prime} ) { - #$$out = substr(*$self->{Prime}, 0, $size, '') ; - $$out = substr(*$self->{Prime}, 0, $size) ; - substr(*$self->{Prime}, 0, $size) = '' ; - if (length $$out == $size) { - #*$self->{InputLengthRemaining} -= length $$out; - return length $$out ; - } - $offset = length $$out ; - } - - my $get_size = $size - $offset ; - - if ( defined *$self->{InputLength} ) { - #*$self->{InputLengthRemaining} += length *$self->{Prime} ; - #*$self->{InputLengthRemaining} = *$self->{InputLength} - # if *$self->{InputLengthRemaining} > *$self->{InputLength}; - $get_size = min($get_size, *$self->{InputLengthRemaining}); - } - - if (defined *$self->{FH}) - { *$self->{FH}->read($$out, $get_size, $offset) } - elsif (defined *$self->{InputEvent}) { - my $got = 1 ; - while (length $$out < $size) { - last - if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0; - } - - if (length $$out > $size ) { - #*$self->{Prime} = substr($$out, $size, length($$out), ''); - *$self->{Prime} = substr($$out, $size, length($$out)); - substr($$out, $size, length($$out)) = ''; - } - - *$self->{EventEof} = 1 if $got <= 0 ; - } - else { - no warnings 'uninitialized'; - my $buf = *$self->{Buffer} ; - $$buf = '' unless defined $$buf ; - #$$out = '' unless defined $$out ; - substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size); - *$self->{BufferOffset} += length($$out) - $offset ; - } - - *$self->{InputLengthRemaining} -= length $$out; - - $self->saveStatus(length $$out < 0 ? Z_DATA_ERROR : 0) ; - - return length $$out; + my $obj = createSelfTiedObject(undef, \$GunzipError); + return $obj->_inf(@_) ; } -sub smartSeek +sub getExtraParams { - my $self = shift ; - my $offset = shift ; - my $truncate = shift; - #print "smartSeek to $offset\n"; - - if (defined *$self->{FH}) - { *$self->{FH}->seek($offset, SEEK_SET) } - else { - *$self->{BufferOffset} = $offset ; - substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = '' - if $truncate; - return 1; - } + use Compress::Zlib::ParseParameters ; + return ( 'ParseExtra' => [1, 1, Parse_boolean, 0] ) ; } -sub smartWrite +sub ckParams { - my $self = shift ; - my $out_data = shift ; + my $self = shift ; + my $got = shift ; - if (defined *$self->{FH}) { - # flush needed for 5.8.0 - defined *$self->{FH}->write($out_data, length $out_data) && - defined *$self->{FH}->flush() ; - } - else { - my $buf = *$self->{Buffer} ; - substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ; - *$self->{BufferOffset} += length($out_data) ; - return 1; - } -} + # gunzip always needs crc32 + $got->value('CRC32' => 1); -sub smartReadExact -{ - return $_[0]->smartRead($_[1], $_[2]) == $_[2]; + return 1; } -sub getTrailingBuffer +sub ckMagic { - my ($self) = $_[0]; - return "" if defined *$self->{FH} || defined *$self->{InputEvent} ; - - my $buf = *$self->{Buffer} ; - my $offset = *$self->{BufferOffset} ; - return substr($$buf, $offset, -1) ; -} + my $self = shift; -sub smartEof -{ - my ($self) = $_[0]; - if (defined *$self->{FH}) - { *$self->{FH}->eof() } - elsif (defined *$self->{InputEvent}) - { *$self->{EventEof} } - else - { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) } -} + my $magic ; + $self->smartReadExact(\$magic, GZIP_ID_SIZE); -sub saveStatus -{ - my $self = shift ; - *$self->{ErrorNo} = shift() + 0 ; - ${ *$self->{Error} } = '' ; + *$self->{HeaderPending} = $magic ; - return *$self->{ErrorNo} ; -} + 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) ; -sub saveErrorString -{ - my $self = shift ; - my $retval = shift ; - ${ *$self->{Error} } = shift ; - *$self->{ErrorNo} = shift() + 0 if @_ ; + *$self->{Type} = 'rfc1952'; - #print "saveErrorString: " . ${ *$self->{Error} } . "\n" ; - return $retval; + return $magic ; } -sub error +sub readHeader { - my $self = shift ; - return ${ *$self->{Error} } ; -} + my $self = shift; + my $magic = shift; -sub errorNo -{ - my $self = shift ; - return *$self->{ErrorNo}; + return $self->_readGzipHeader($magic); } -sub HeaderError +sub chkTrailer { - my ($self) = shift; - return $self->saveErrorString(undef, "Header Error: $_[0]", Z_DATA_ERROR); -} + my $self = shift; + my $trailer = shift; -sub TrailerError -{ - my ($self) = shift; - return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", Z_DATA_ERROR); -} + # Check CRC & ISIZE + my ($CRC32, $ISIZE) = unpack("V V", $trailer) ; + *$self->{Info}{CRC32} = $CRC32; + *$self->{Info}{ISIZE} = $ISIZE; -sub TruncatedHeader -{ - my ($self) = shift; - return $self->HeaderError("Truncated in $_[0] Section"); -} + if (*$self->{Strict}) { + return $self->TrailerError("CRC mismatch") + if $CRC32 != *$self->{Uncomp}->crc32() ; -sub isZipMagic -{ - my $buffer = shift ; - return 0 if length $buffer < 4 ; - my $sig = unpack("V", $buffer) ; - return $sig == 0x04034b50 ; + my $exp_isize = *$self->{Uncomp}->uncompressedBytes(); + return $self->TrailerError("ISIZE mismatch. Got $ISIZE" + . ", expected $exp_isize") + if $ISIZE != $exp_isize ; + } + + return 1; } sub isGzipMagic @@ -255,108 +120,6 @@ sub isGzipMagic return $id1 == GZIP_ID1 && $id2 == GZIP_ID2 ; } -sub isZlibMagic -{ - my $buffer = shift ; - return 0 if length $buffer < ZLIB_HEADER_SIZE ; - my $hdr = unpack("n", $buffer) ; - return $hdr % 31 == 0 ; -} - -sub _isRaw -{ - 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->{Inflate}->inflate($temp_buf, $buffer) ; - my $buf_len = *$self->{Inflate}->inflateCount(); - - # zlib before 1.2 needs an extra byte after the compressed data - # for RawDeflate - if ($status == Z_OK && $self->smartEof()) { - my $byte = ' '; - $status = *$self->{Inflate}->inflate(\$byte, $buffer) ; - return $self->saveErrorString(undef, "Inflation Error: $status", $status) - unless $self->saveStatus($status) == Z_OK || $status == Z_STREAM_END ; - $buf_len += *$self->{Inflate}->inflateCount(); - } - - return $self->saveErrorString(undef, "unexpected end of file", Z_DATA_ERROR) - if $self->saveStatus($status) != Z_STREAM_END && $self->smartEof() ; - - return $self->saveErrorString(undef, "Inflation Error: $status", $status) - unless $status == Z_OK || $status == Z_STREAM_END ; - - if ($status == Z_STREAM_END) { - if (*$self->{MultiStream} - && (length $temp_buf || ! $self->smartEof())){ - *$self->{NewStream} = 1 ; - *$self->{EndStream} = 0 ; - *$self->{Prime} = $temp_buf . *$self->{Prime} ; - } - else { - *$self->{EndStream} = 1 ; - *$self->{Trailing} = $temp_buf . $self->getTrailingBuffer(); - } - } - *$self->{HeaderPending} = $buffer ; - *$self->{InflatedBytesRead} = $buf_len ; - *$self->{TotalInflatedBytesRead} += $buf_len ; - *$self->{Type} = 'rfc1951'; - - $self->saveStatus(Z_OK); - - return { - 'Type' => 'rfc1951', - 'HeaderLength' => 0, - 'TrailerLength' => 0, - 'Header' => '' - }; -} - -sub _guessCompression -{ - my $self = shift ; - - # Check raw first in case the first few bytes happen to match - # the signatures of gzip/deflate. - my $got = $self->_isRaw() ; - return $got if defined $got ; - - *$self->{Prime} = *$self->{HeaderPending} . *$self->{Prime} ; - *$self->{HeaderPending} = ''; - *$self->{Inflate}->inflateReset(); - - my $magic = '' ; - my $status ; - $self->smartReadExact(\$magic, GZIP_ID_SIZE) - or return $self->HeaderError("Minimum header size is " . - GZIP_ID_SIZE . " bytes") ; - - if (isGzipMagic($magic)) { - $status = $self->_readGzipHeader($magic); - delete *$self->{Transparent} if ! defined $status ; - return $status ; - } - elsif ( $status = $self->_readDeflateHeader($magic) ) { - return $status ; - } - - *$self->{Prime} = $magic . *$self->{HeaderPending} . *$self->{Prime} ; - *$self->{HeaderPending} = ''; - $self->saveErrorString(undef, "unknown compression format", Z_DATA_ERROR); -} - sub _readFullGzipHeader($) { my ($self) = @_ ; @@ -491,6 +254,7 @@ sub _readGzipHeader($) return { 'Type' => 'rfc1952', + 'FingerprintLength' => 2, 'HeaderLength' => length $keep, 'TrailerLength' => GZIP_TRAILER_SIZE, 'Header' => $keep, @@ -522,1299 +286,9 @@ sub _readGzipHeader($) } } -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, 2)); - my $lastModDate = unpack ("v", substr($buffer, 12-4, 2)); - my $crc32 = unpack ("v", substr($buffer, 14-4, 4)); - my $compressedLength = unpack ("V", substr($buffer, 18-4, 4)); - my $uncompressedLength = 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; - - if ($filename_length) - { - $self->smartReadExact(\$filename, $filename_length) - or return $self->HeaderError("xxx"); - $keep .= $filename ; - } - - if ($extra_length) - { - $self->smartReadExact(\$extraField, $extra_length) - or return $self->HeaderError("xxx"); - $keep .= $extraField ; - } - - *$self->{Type} = 'zip'; - - return { - 'Type' => 'zip', - 'HeaderLength' => length $keep, - 'TrailerLength' => $gpFlag & 0x08 ? 16 : 0, - 'Header' => $keep, - -# '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, - } -} - -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', - '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 , - -}; -} - - -sub checkParams -{ - my $class = shift ; - my $type = shift ; - - - my $Valid = { - #'Input' => [Parse_store_ref, undef], - - 'BlockSize' => [Parse_unsigned, 16 * 1024], - 'AutoClose' => [Parse_boolean, 0], - 'Strict' => [Parse_boolean, 0], - #'Lax' => [Parse_boolean, 1], - 'Append' => [Parse_boolean, 0], - 'Prime' => [Parse_any, undef], - 'MultiStream' => [Parse_boolean, 0], - 'Transparent' => [Parse_any, 1], - 'Scan' => [Parse_boolean, 0], - 'InputLength' => [Parse_unsigned, undef], - 'BinModeOut' => [Parse_boolean, 0], - #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0, - # ContinueAfterEof - } ; - - $Valid->{'ParseExtra'} = [Parse_boolean, 0] - if $type eq 'rfc1952' ; - - my $got = Compress::Zlib::ParseParameters::new(); - - $got->parse($Valid, @_ ) - or croak "$class: $got->{Error}" ; - - return $got; -} - -sub new -{ - my $class = shift ; - my $type = shift ; - my $got = shift; - my $error_ref = shift ; - my $append_mode = shift ; - - croak("$class: Missing Input parameter") - if ! @_ && ! $got ; - - my $inValue = shift ; - - if (! $got) - { - $got = checkParams($class, $type, @_) - or return undef ; - } - - my $inType = whatIsInput($inValue, 1); - - ckInputParam($class, $inValue, $error_ref, 1) - or return undef ; - - my $obj = bless Symbol::gensym(), ref($class) || $class; - tie *$obj, $obj if $] >= 5.005; - - - $$error_ref = '' ; - *$obj->{Error} = $error_ref ; - *$obj->{InNew} = 1; - - if ($inType eq 'buffer' || $inType eq 'code') { - *$obj->{Buffer} = $inValue ; - *$obj->{InputEvent} = $inValue - if $inType eq 'code' ; - } - else { - if ($inType eq 'handle') { - *$obj->{FH} = $inValue ; - *$obj->{Handle} = 1 ; - # Need to rewind for Scan - #seek(*$obj->{FH}, 0, SEEK_SET) if $got->value('Scan'); - *$obj->{FH}->seek(0, SEEK_SET) if $got->value('Scan'); - } - else { - my $mode = '<'; - $mode = '+<' if $got->value('Scan'); - *$obj->{StdIO} = ($inValue eq '-'); - *$obj->{FH} = new IO::File "$mode $inValue" - or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ; - *$obj->{LineNo} = 0; - } - - setBinModeInput(*$obj->{FH}) ; - - my $buff = "" ; - *$obj->{Buffer} = \$buff ; - } - - - *$obj->{InputLength} = $got->parsed('InputLength') - ? $got->value('InputLength') - : undef ; - *$obj->{InputLengthRemaining} = $got->value('InputLength'); - *$obj->{BufferOffset} = 0 ; - *$obj->{AutoClose} = $got->value('AutoClose'); - *$obj->{Strict} = $got->value('Strict'); - #*$obj->{Strict} = ! $got->value('Lax'); - *$obj->{BlockSize} = $got->value('BlockSize'); - *$obj->{Append} = $got->value('Append'); - *$obj->{AppendOutput} = $append_mode || $got->value('Append'); - *$obj->{Transparent} = $got->value('Transparent'); - *$obj->{MultiStream} = $got->value('MultiStream'); - *$obj->{Scan} = $got->value('Scan'); - *$obj->{ParseExtra} = $got->value('ParseExtra') - || $got->value('Strict') ; - #|| ! $got->value('Lax') ; - *$obj->{Type} = $type; - *$obj->{Prime} = $got->value('Prime') || '' ; - *$obj->{Pending} = ''; - *$obj->{Plain} = 0; - *$obj->{PlainBytesRead} = 0; - *$obj->{InflatedBytesRead} = 0; - *$obj->{ISize} = 0; - *$obj->{TotalInflatedBytesRead} = 0; - *$obj->{NewStream} = 0 ; - *$obj->{EventEof} = 0 ; - *$obj->{ClassName} = $class ; - - my $status; - - if (*$obj->{Scan}) - { - (*$obj->{Inflate}, $status) = new Compress::Zlib::InflateScan - -CRC32 => $type eq 'rfc1952' || - $type eq 'any', - -ADLER32 => $type eq 'rfc1950' || - $type eq 'any', - -WindowBits => - MAX_WBITS ; - } - else - { - (*$obj->{Inflate}, $status) = new Compress::Zlib::Inflate - -AppendOutput => 1, - -CRC32 => $type eq 'rfc1952' || - $type eq 'any', - -ADLER32 => $type eq 'rfc1950' || - $type eq 'any', - -WindowBits => - MAX_WBITS ; - } - - return $obj->saveErrorString(undef, "Could not create Inflation object: $status") - if $obj->saveStatus($status) != Z_OK ; - - if ($type eq 'rfc1952') - { - *$obj->{Info} = $obj->_readFullGzipHeader() ; - } - elsif ($type eq 'zip') - { - *$obj->{Info} = $obj->_readFullZipHeader() ; - } - elsif ($type eq 'rfc1950') - { - *$obj->{Info} = $obj->_readDeflateHeader() ; - } - elsif ($type eq 'rfc1951') - { - *$obj->{Info} = $obj->_isRaw() ; - } - elsif ($type eq 'any') - { - *$obj->{Info} = $obj->_guessCompression() ; - } - - if (! defined *$obj->{Info}) - { - return undef unless *$obj->{Transparent}; - - *$obj->{Type} = 'plain'; - *$obj->{Plain} = 1; - *$obj->{PlainBytesRead} = length *$obj->{HeaderPending} ; - } - - push @{ *$obj->{InfoList} }, *$obj->{Info} ; - *$obj->{Pending} = *$obj->{HeaderPending} - if *$obj->{Plain} || *$obj->{Type} eq 'rfc1951'; - - $obj->saveStatus(0) ; - *$obj->{InNew} = 0; - - return $obj; -} - -#sub _inf -#{ -# my $class = shift ; -# my $type = shift ; -# my $error_ref = shift ; -# -# my $name = (caller(1))[3] ; -# -# croak "$name: expected at least 2 parameters\n" -# unless @_ >= 2 ; -# -# my $input = shift ; -# my $output = shift ; -# -# ckInOutParams($name, $input, $output, $error_ref) -# or return undef ; -# -# my $outType = whatIs($output); -# -# my $gunzip = new($class, $type, $error_ref, 1, $input, @_) -# or return undef ; -# -# my $fh ; -# if ($outType eq 'filename') { -# my $mode = '>' ; -# $mode = '>>' -# if *$gunzip->{Append} ; -# $fh = new IO::File "$mode $output" -# or return $gunzip->saveErrorString(undef, "cannot open file '$output': $!", $!) ; -# } -# -# if ($outType eq 'handle') { -# $fh = $output; -# if (*$gunzip->{Append}) { -# seek($fh, 0, SEEK_END) -# or return $gunzip->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; -# } -# } -# -# my $buff = '' ; -# $buff = $output if $outType eq 'buffer' ; -# my $status ; -# while (($status = $gunzip->read($buff)) > 0) { -# if ($fh) { -# print $fh $buff -# or return $gunzip->saveErrorString(undef, "Error writing to output file: $!", $!); -# } -# } -# -# return undef -# if $status < 0 ; -# -# $gunzip->close() -# or return undef ; -# -# if ( $outType eq 'filename' || -# ($outType eq 'handle' && *$gunzip->{AutoClose})) { -# $fh->close() -# or return $gunzip->saveErrorString(undef, $!, $!); -# } -# -# return 1 ; -#} - -sub _inf -{ - my $class = shift ; - my $type = shift ; - my $error_ref = shift ; - - my $name = (caller(1))[3] ; - - croak "$name: expected at least 1 parameters\n" - unless @_ >= 1 ; - - my $input = shift ; - my $haveOut = @_ ; - my $output = shift ; - - my $x = new Validator($class, $type, $error_ref, $name, $input, $output) - or return undef ; - - push @_, $output if $haveOut && $x->{Hash}; - - my $got = checkParams($name, $type, @_) - or return undef ; - - $x->{Got} = $got ; - - if ($x->{Hash}) - { - while (my($k, $v) = each %$input) - { - $v = \$input->{$k} - unless defined $v ; - - _singleTarget($x, 1, $k, $v, @_) - or return undef ; - } - - return keys %$input ; - } - - if ($x->{GlobMap}) - { - $x->{oneInput} = 1 ; - foreach my $pair (@{ $x->{Pairs} }) - { - my ($from, $to) = @$pair ; - _singleTarget($x, 1, $from, $to, @_) - or return undef ; - } - - return scalar @{ $x->{Pairs} } ; - } - - #if ($x->{outType} eq 'array' || $x->{outType} eq 'hash') - if (! $x->{oneOutput} ) - { - my $inFile = ($x->{inType} eq 'filenames' - || $x->{inType} eq 'filename'); - - $x->{inType} = $inFile ? 'filename' : 'buffer'; - my $ot = $x->{outType} ; - $x->{outType} = 'buffer'; - - foreach my $in ($x->{oneInput} ? $input : @$input) - { - my $out ; - $x->{oneInput} = 1 ; - - _singleTarget($x, $inFile, $in, \$out, @_) - or return undef ; - - if ($ot eq 'array') - { push @$output, \$out } - else - { $output->{$in} = \$out } - } - - return 1 ; - } - - # finally the 1 to 1 and n to 1 - return _singleTarget($x, 1, $input, $output, @_); - - croak "should not be here" ; -} - -sub retErr -{ - my $x = shift ; - my $string = shift ; - - ${ $x->{Error} } = $string ; - - return undef ; -} - -sub _singleTarget -{ - my $x = shift ; - my $inputIsFilename = shift; - my $input = shift; - my $output = shift; - - $x->{buff} = '' ; - - my $fh ; - if ($x->{outType} eq 'filename') { - my $mode = '>' ; - $mode = '>>' - if $x->{Got}->value('Append') ; - $x->{fh} = new IO::File "$mode $output" - or return retErr($x, "cannot open file '$output': $!") ; - binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut'); - - } - - elsif ($x->{outType} eq 'handle') { - $x->{fh} = $output; - binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut'); - if ($x->{Got}->value('Append')) { - seek($x->{fh}, 0, SEEK_END) - or return retErr($x, "Cannot seek to end of output filehandle: $!") ; - } - } - - - elsif ($x->{outType} eq 'buffer' ) - { - $$output = '' - unless $x->{Got}->value('Append'); - $x->{buff} = $output ; - } - - if ($x->{oneInput}) - { - defined _rd2($x, $input, $inputIsFilename) - or return undef; - } - else - { - my $inputIsFilename = ($x->{inType} ne 'array'); - - for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) - { - defined _rd2($x, $element, $inputIsFilename) - or return undef ; - } - } - - - if ( ($x->{outType} eq 'filename' && $output ne '-') || - ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) { - $x->{fh}->close() - or return retErr($x, $!); - #or return $gunzip->saveErrorString(undef, $!, $!); - delete $x->{fh}; - } - - return 1 ; -} - -sub _rd2 -{ - my $x = shift ; - my $input = shift; - my $inputIsFilename = shift; - - my $gunzip = new($x->{Class}, $x->{Type}, $x->{Got}, $x->{Error}, 1, $input, @_) - or return undef ; - - my $status ; - my $fh = $x->{fh}; - - while (($status = $gunzip->read($x->{buff})) > 0) { - if ($fh) { - print $fh $x->{buff} - or return $gunzip->saveErrorString(undef, "Error writing to output file: $!", $!); - $x->{buff} = '' ; - } - } - - return undef - if $status < 0 ; - - $gunzip->close() - or return undef ; - - return 1 ; -} - -sub TIEHANDLE -{ - return $_[0] if ref($_[0]); - die "OOPS\n" ; - -} - -sub UNTIE -{ - my $self = shift ; -} - - -sub getHeaderInfo -{ - my $self = shift ; - return *$self->{Info}; -} - -sub _raw_read -{ - # return codes - # >0 - ok, number of bytes read - # =0 - ok, eof - # <0 - not ok - - my $self = shift ; - - return G_EOF if *$self->{Closed} ; - #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; - return G_EOF if *$self->{EndStream} ; - - my $buffer = shift ; - my $scan_mode = shift ; - - if (*$self->{Plain}) { - my $tmp_buff ; - my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ; - - return $self->saveErrorString(G_ERR, "Error reading data: $!", $!) - if $len < 0 ; - - if ($len == 0 ) { - *$self->{EndStream} = 1 ; - } - else { - *$self->{PlainBytesRead} += $len ; - $$buffer .= $tmp_buff; - } - - return $len ; - } - - if (*$self->{NewStream}) { - *$self->{NewStream} = 0 ; - *$self->{EndStream} = 0 ; - *$self->{Inflate}->inflateReset(); - - if (*$self->{Type} eq 'rfc1952') - { - *$self->{Info} = $self->_readFullGzipHeader() ; - } - elsif (*$self->{Type} eq 'zip') - { - *$self->{Info} = $self->_readFullZipHeader() ; - } - elsif (*$self->{Type} eq 'rfc1950') - { - *$self->{Info} = $self->_readDeflateHeader() ; - } - elsif (*$self->{Type} eq 'rfc1951') - { - *$self->{Info} = $self->_isRaw() ; - *$self->{Pending} = *$self->{HeaderPending} - if defined *$self->{Info} ; - } - - return G_ERR unless defined *$self->{Info} ; - - push @{ *$self->{InfoList} }, *$self->{Info} ; - - if (*$self->{Type} eq 'rfc1951') { - $$buffer .= *$self->{Pending} ; - my $len = length *$self->{Pending} ; - *$self->{Pending} = ''; - return $len; - } - } - - my $temp_buf ; - my $status = $self->smartRead(\$temp_buf, *$self->{BlockSize}) ; - return $self->saveErrorString(G_ERR, "Error Reading Data") - if $status < 0 ; - - if ($status == 0 ) { - *$self->{Closed} = 1 ; - *$self->{EndStream} = 1 ; - return $self->saveErrorString(G_ERR, "unexpected end of file", Z_DATA_ERROR); - } - - my $before_len = defined $$buffer ? length $$buffer : 0 ; - $status = *$self->{Inflate}->inflate(\$temp_buf, $buffer) ; - - return $self->saveErrorString(G_ERR, "Inflation Error: $status") - unless $self->saveStatus($status) == Z_OK || $status == Z_STREAM_END ; - - my $buf_len = *$self->{Inflate}->inflateCount(); - - # zlib before 1.2 needs an extra byte after the compressed data - # for RawDeflate - if ($status == Z_OK && *$self->{Type} eq 'rfc1951' && $self->smartEof()) { - my $byte = ' '; - $status = *$self->{Inflate}->inflate(\$byte, $buffer) ; - - $buf_len += *$self->{Inflate}->inflateCount(); - - return $self->saveErrorString(G_ERR, "Inflation Error: $status") - unless $self->saveStatus($status) == Z_OK || $status == Z_STREAM_END ; - } - - - return $self->saveErrorString(G_ERR, "unexpected end of file", Z_DATA_ERROR) - if $status != Z_STREAM_END && $self->smartEof() ; - - *$self->{InflatedBytesRead} += $buf_len ; - *$self->{TotalInflatedBytesRead} += $buf_len ; - my $rest = GZIP_ISIZE_MAX - *$self->{ISize} ; - if ($buf_len > $rest) { - *$self->{ISize} = $buf_len - $rest - 1; - } - else { - *$self->{ISize} += $buf_len ; - } - - if ($status == Z_STREAM_END) { - - *$self->{EndStream} = 1 ; - - if (*$self->{Type} eq 'rfc1951' || ! *$self->{Info}{TrailerLength}) - { - *$self->{Trailing} = $temp_buf . $self->getTrailingBuffer(); - } - else - { - # Only rfc1950 & 1952 have a trailer - - my $trailer_size = *$self->{Info}{TrailerLength} ; - - #if ($scan_mode) { - # my $offset = *$self->{Inflate}->getLastBufferOffset(); - # substr($temp_buf, 0, $offset) = '' ; - #} - - if (length $temp_buf < $trailer_size) { - my $buff; - my $want = $trailer_size - length $temp_buf; - my $got = $self->smartRead(\$buff, $want) ; - if ($got != $want && *$self->{Strict} ) { - my $len = length($temp_buf) + length($buff); - return $self->TrailerError("trailer truncated. Expected " . - "$trailer_size bytes, got $len"); - } - $temp_buf .= $buff; - } - - if (length $temp_buf >= $trailer_size) { - - #my $trailer = substr($temp_buf, 0, $trailer_size, '') ; - my $trailer = substr($temp_buf, 0, $trailer_size) ; - substr($temp_buf, 0, $trailer_size) = '' ; - - if (*$self->{Type} eq 'rfc1952') { - # 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->{Inflate}->crc32() ; - - my $exp_isize = *$self->{ISize}; - return $self->TrailerError("ISIZE mismatch. Got $ISIZE" - . ", expected $exp_isize") - if $ISIZE != $exp_isize ; - } - } - elsif (*$self->{Type} eq 'zip') { - # Check CRC & ISIZE - my ($sig, $CRC32, $cSize, $uSize) = unpack("V V V V", $trailer) ; - return $self->TrailerError("Data Descriptor signature") - if $sig != 0x08074b50; - - if (*$self->{Strict}) { - return $self->TrailerError("CRC mismatch") - if $CRC32 != *$self->{Inflate}->crc32() ; - - } - } - elsif (*$self->{Type} eq 'rfc1950') { - my $ADLER32 = unpack("N", $trailer) ; - *$self->{Info}{ADLER32} = $ADLER32; - return $self->TrailerError("CRC mismatch") - if *$self->{Strict} && $ADLER32 != *$self->{Inflate}->adler32() ; - - } - - if (*$self->{MultiStream} - && (length $temp_buf || ! $self->smartEof())){ - *$self->{NewStream} = 1 ; - *$self->{EndStream} = 0 ; - *$self->{Prime} = $temp_buf . *$self->{Prime} ; - return $buf_len ; - } - } - - *$self->{Trailing} = $temp_buf .$self->getTrailingBuffer(); - } - } - - - # return the number of uncompressed bytes read - return $buf_len ; -} - -#sub isEndStream -#{ -# my $self = shift ; -# return *$self->{NewStream} || -# *$self->{EndStream} ; -#} - -sub streamCount -{ - my $self = shift ; - return 1 if ! defined *$self->{InfoList}; - return scalar @{ *$self->{InfoList} } ; -} - -sub read -{ - # return codes - # >0 - ok, number of bytes read - # =0 - ok, eof - # <0 - not ok - - my $self = shift ; - - return G_EOF if *$self->{Closed} ; - return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; - - my $buffer ; - - #croak(*$self->{ClassName} . "::read: buffer parameter is read-only") - # if Compress::Zlib::_readonly_ref($_[0]); - - if (ref $_[0] ) { - croak(*$self->{ClassName} . "::read: buffer parameter is read-only") - if readonly(${ $_[0] }); - - croak *$self->{ClassName} . "::read: not a scalar reference $_[0]" - unless ref $_[0] eq 'SCALAR' ; - $buffer = $_[0] ; - } - else { - croak(*$self->{ClassName} . "::read: buffer parameter is read-only") - if readonly($_[0]); - - $buffer = \$_[0] ; - } - - my $length = $_[1] ; - my $offset = $_[2] || 0; - - # the core read will return 0 if asked for 0 bytes - return 0 if defined $length && $length == 0 ; - - $length = $length || 0; - - croak(*$self->{ClassName} . "::read: length parameter is negative") - if $length < 0 ; - - $$buffer = '' unless *$self->{AppendOutput} || $offset ; - - # Short-circuit if this is a simple read, with no length - # or offset specified. - unless ( $length || $offset) { - if (length *$self->{Pending}) { - $$buffer .= *$self->{Pending} ; - my $len = length *$self->{Pending}; - *$self->{Pending} = '' ; - return $len ; - } - else { - my $len = 0; - $len = $self->_raw_read($buffer) - while ! *$self->{EndStream} && $len == 0 ; - return $len ; - } - } - - # Need to jump through more hoops - either length or offset - # or both are specified. - #*$self->{Pending} = '' if ! length *$self->{Pending} ; - my $out_buffer = \*$self->{Pending} ; - - while (! *$self->{EndStream} && length($$out_buffer) < $length) - { - my $buf_len = $self->_raw_read($out_buffer); - return $buf_len - if $buf_len < 0 ; - } - - $length = length $$out_buffer - if length($$out_buffer) < $length ; - - if ($offset) { - $$buffer .= "\x00" x ($offset - length($$buffer)) - if $offset > length($$buffer) ; - #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ; - substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ; - substr($$out_buffer, 0, $length) = '' ; - } - else { - #$$buffer .= substr($$out_buffer, 0, $length, '') ; - $$buffer .= substr($$out_buffer, 0, $length) ; - substr($$out_buffer, 0, $length) = '' ; - } - - return $length ; -} - -sub _getline -{ - my $self = shift ; - - # Slurp Mode - if ( ! defined $/ ) { - my $data ; - 1 while $self->read($data) > 0 ; - return \$data ; - } - - # Paragraph Mode - if ( ! length $/ ) { - my $paragraph ; - while ($self->read($paragraph) > 0 ) { - if ($paragraph =~ s/^(.*?\n\n+)//s) { - *$self->{Pending} = $paragraph ; - my $par = $1 ; - return \$par ; - } - } - return \$paragraph; - } - - # Line Mode - { - my $line ; - my $endl = quotemeta($/); # quote in case $/ contains RE meta chars - while ($self->read($line) > 0 ) { - if ($line =~ s/^(.*?$endl)//s) { - *$self->{Pending} = $line ; - $. = ++ *$self->{LineNo} ; - my $l = $1 ; - return \$l ; - } - } - $. = ++ *$self->{LineNo} if defined($line); - return \$line; - } -} - -sub getline -{ - my $self = shift; - my $current_append = *$self->{AppendOutput} ; - *$self->{AppendOutput} = 1; - my $lineref = $self->_getline(); - *$self->{AppendOutput} = $current_append; - return $$lineref ; -} - -sub getlines -{ - my $self = shift; - croak *$self->{ClassName} . "::getlines: called in scalar context\n" unless wantarray; - my($line, @lines); - push(@lines, $line) while defined($line = $self->getline); - return @lines; -} - -sub READLINE -{ - goto &getlines if wantarray; - goto &getline; -} - -sub getc -{ - my $self = shift; - my $buf; - return $buf if $self->read($buf, 1); - return undef; -} - -sub ungetc -{ - my $self = shift; - *$self->{Pending} = "" unless defined *$self->{Pending} ; - *$self->{Pending} = $_[0] . *$self->{Pending} ; -} - -sub trailingData -{ - my $self = shift ; - return \"" if ! defined *$self->{Trailing} ; - return \*$self->{Trailing} ; -} - -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 ; +1; - 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", Z_DATA_ERROR); - } - } - - $status = *$self->{Inflate}->inflateSync($temp_buf) ; - - if ($status == Z_OK) - { - *$self->{Pending} .= $temp_buf ; - return 1 ; - } - - last unless $status = Z_DATA_ERROR ; - } - - return 0; -} - -sub eof -{ - my $self = shift ; - - return (*$self->{Closed} || - (!length *$self->{Pending} - && ( $self->smartEof() || *$self->{EndStream}))) ; -} - -sub tell -{ - my $self = shift ; - - my $in ; - if (*$self->{Plain}) { - $in = *$self->{PlainBytesRead} ; - } - else { - $in = *$self->{TotalInflatedBytesRead} ; - } - - my $pending = length *$self->{Pending} ; - - return 0 if $pending > $in ; - return $in - $pending ; -} - -sub close -{ - # todo - what to do if close is called before the end of the gzip file - # do we remember any trailing data? - my $self = shift ; - - return 1 if *$self->{Closed} ; - - untie *$self - if $] >= 5.008 ; - - my $status = 1 ; - - if (defined *$self->{FH}) { - if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { - #if ( *$self->{AutoClose}) { - $! = 0 ; - $status = *$self->{FH}->close(); - return $self->saveErrorString(0, $!, $!) - if !*$self->{InNew} && $self->saveStatus($!) != 0 ; - } - delete *$self->{FH} ; - $! = 0 ; - } - *$self->{Closed} = 1 ; - - return 1; -} - -sub DESTROY -{ - my $self = shift ; - $self->close() ; -} - -sub seek -{ - my $self = shift ; - my $position = shift; - my $whence = shift ; - - my $here = $self->tell() ; - my $target = 0 ; - - - if ($whence == SEEK_SET) { - $target = $position ; - } - elsif ($whence == SEEK_CUR) { - $target = $here + $position ; - } - elsif ($whence == SEEK_END) { - $target = $position ; - croak *$self->{ClassName} . "::seek: SEEK_END not allowed" ; - } - else { - croak *$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter"; - } - - # short circuit if seeking to current offset - return 1 if $target == $here ; - - # Outlaw any attempt to seek backwards - croak *$self->{ClassName} ."::seek: cannot seek backwards" - if $target < $here ; - - # Walk the file to the new offset - my $offset = $target - $here ; - - my $buffer ; - $self->read($buffer, $offset) == $offset - or return 0 ; - - return 1 ; -} - -sub fileno -{ - my $self = shift ; - return defined *$self->{FH} - ? fileno *$self->{FH} - : undef ; -} - -sub binmode -{ - 1; -# my $self = shift ; -# return defined *$self->{FH} -# ? binmode *$self->{FH} -# : 1 ; -} - -*BINMODE = \&binmode; -*SEEK = \&seek; -*READ = \&read; -*sysread = \&read; -*TELL = \&tell; -*EOF = \&eof; - -*FILENO = \&fileno; -*CLOSE = \&close; - -sub _notAvailable -{ - my $name = shift ; - #return sub { croak "$name Not Available" ; } ; - return sub { croak "$name Not Available: File opened only for intput" ; } ; -} - - -*print = _notAvailable('print'); -*PRINT = _notAvailable('print'); -*printf = _notAvailable('printf'); -*PRINTF = _notAvailable('printf'); -*write = _notAvailable('write'); -*WRITE = _notAvailable('write'); - -#*sysread = \&read; -#*syswrite = \&_notAvailable; - -#package IO::_infScan ; -# -#*_raw_read = \&IO::BaseInflate::_raw_read ; -#*smartRead = \&IO::BaseInflate::smartRead ; -#*smartWrite = \&IO::BaseInflate::smartWrite ; -#*smartSeek = \&IO::BaseInflate::smartSeek ; - -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->{Inflate}->getLastBlockOffset(); - $_[0] = $headerLength + *$self->{Inflate}->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->{Inflate}->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 ($status, $def) = *$self->{Inflate}->createDeflateStream( - -AppendOutput => 1, - -WindowBits => - MAX_WBITS, - -CRC32 => *$self->{Type} eq 'rfc1952' - || *$self->{Type} eq 'zip', - -ADLER32 => *$self->{Type} eq 'rfc1950', - ); - - return wantarray ? ($status, $def) : $def ; -} - - -package IO::Uncompress::Gunzip ; - -1 ; __END__ @@ -1886,34 +360,34 @@ B<WARNING -- This is a Beta release>. -This module provides a Perl interface that allows the reading of +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. +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. +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"; - gunzip \%hash [,OPTS] - or die "gunzip failed: $GunzipError\n"; + The functional interface needs Perl5.005 or better. =head2 gunzip $input => $output [, OPTS] -If the first parameter is not a hash reference C<gunzip> expects -at least two parameters, C<$input> and C<$output>. + +C<gunzip> expects at least two parameters, C<$input> and C<$output>. =head3 The C<$input> parameter @@ -1943,13 +417,15 @@ from C<$$input>. =item An array reference -If C<$input> is an array reference, the input data will be read from each -element of the array in turn. The action taken by C<gunzip> with -each element of the array will depend on the type of data stored -in it. You can mix and match any of the types defined in this list, -excluding other array or hash references. +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 data types before any data is uncompressed. +contains valid filenames before any data is uncompressed. + + =item An Input FileGlob string @@ -1977,36 +453,28 @@ uncompressed data. This parameter can take one of these forms. =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. +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. +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>. +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. -=item A Hash Reference - -If C<$output> is a hash reference, the uncompressed data will be written -to C<$output{$input}> as a scalar reference. - -When C<$output> is a hash reference, C<$input> must be either a filename or -list of filenames. Anything else is an error. - =item An Array Reference -If C<$output> is an array reference, the uncompressed data will be pushed -onto the array. +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. =item An Output FileGlob @@ -2021,60 +489,13 @@ string. Anything else is an error. If the C<$output> parameter is any other type, C<undef> will be returned. -=head2 gunzip \%hash [, OPTS] - -If the first parameter is a hash reference, C<\%hash>, this will be used to -define both the source of compressed data and to control where the -uncompressed data is output. Each key/value pair in the hash defines a -mapping between an input filename, stored in the key, and an output -file/buffer, stored in the value. Although the input can only be a filename, -there is more flexibility to control the destination of the uncompressed -data. This is determined by the type of the value. Valid types are -=over 5 - -=item undef - -If the value is C<undef> the uncompressed data will be written to the -value as a scalar reference. - -=item A filename - -If the value 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 value 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 the value is a scalar reference, the uncompressed data will be stored -in the buffer that is referenced by the scalar. - - -=item A Hash Reference - -If the value is a hash reference, the uncompressed data will be written -to C<$hash{$input}> as a scalar reference. - -=item An Array Reference - -If C<$output> is an array reference, the uncompressed data will be pushed -onto the array. - -=back - -Any other type is a error. =head2 Notes When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the uncompressed input files/buffers will all be stored in -C<$output> as a single uncompressed stream. +file/buffer the uncompressed input files/buffers will all be stored +in C<$output> as a single uncompressed stream. @@ -2088,8 +509,8 @@ L</"Constructor Options"> section below. =item AutoClose =E<gt> 0|1 -This option applies to any input or output data streams to C<gunzip> -that are filehandles. +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 @@ -2099,10 +520,27 @@ This parameter defaults to 0. +=item BinModeOut =E<gt> 0|1 + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + + + + + =item -Append =E<gt> 0|1 TODO +=item -MultiStream =E<gt> 0|1 + +Creates a new stream after each file. + +Defaults to 1. + =back @@ -2175,11 +613,11 @@ The format of the constructor for IO::Uncompress::Gunzip is shown below 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 +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>; @@ -2253,8 +691,9 @@ 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. +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 -Transparent =E<gt> 0|1 @@ -2265,20 +704,21 @@ This option defaults to 1. =item -BlockSize =E<gt> $num -When reading the compressed input data, IO::Uncompress::Gunzip will read it in blocks -of C<$num> bytes. +When reading the compressed input data, IO::Uncompress::Gunzip will read it in +blocks of C<$num> bytes. This option defaults to 4096. =item -InputLength =E<gt> $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. +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 +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. @@ -2289,11 +729,11 @@ This option defaults to off. 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 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. +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. @@ -2302,8 +742,8 @@ Defaults to 0. 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. +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. @@ -2329,8 +769,8 @@ If the gzip header contains a name field (FNAME) it consists solely of ISO =item 3 -If the gzip header contains a comment field (FCOMMENT) it consists solely of -ISO 8859-1 characters plus line-feed. +If the gzip header contains a comment field (FCOMMENT) it consists solely +of ISO 8859-1 characters plus line-feed. =item 4 @@ -2348,8 +788,8 @@ 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. +The value of the ISIZE fields read must match the length of the +uncompressed data actually read from the file. =back @@ -2386,12 +826,12 @@ Usage is 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. +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. +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. =head2 read @@ -2405,13 +845,13 @@ Usage is 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. +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. +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. =head2 getline @@ -2456,29 +896,28 @@ TODO Usage is - $hdr = $z->getHeaderInfo() - -TODO - - - - - -This method returns a hash reference that contains the contents of each of the -header fields defined in RFC1952. + $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 -=over 5 +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. +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 @@ -2633,7 +1072,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005 Paul Marquess. All rights reserved. +Copyright (c) 2005-2006 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/Compress/Zlib/lib/IO/Uncompress/Inflate.pm b/ext/Compress/Zlib/lib/IO/Uncompress/Inflate.pm index 656b78a1b5..4193917288 100644 --- a/ext/Compress/Zlib/lib/IO/Uncompress/Inflate.pm +++ b/ext/Compress/Zlib/lib/IO/Uncompress/Inflate.pm @@ -3,33 +3,172 @@ package IO::Uncompress::Inflate ; use strict ; use warnings; -use IO::Uncompress::Gunzip ; +use Compress::Zlib::Common qw(createSelfTiedObject); +use Compress::Zlib::FileConstants; + +use IO::Uncompress::RawInflate ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; $InflateError = ''; -@ISA = qw( Exporter IO::BaseInflate ); +@ISA = qw( Exporter IO::Uncompress::RawInflate ); @EXPORT_OK = qw( $InflateError inflate ) ; -%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ; +%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ; push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; Exporter::export_ok_tags('all'); sub new { - my $pkg = shift ; - return IO::BaseInflate::new($pkg, 'rfc1950', undef, \$InflateError, 0, @_); + my $class = shift ; + my $obj = createSelfTiedObject($class, \$InflateError); + + $obj->_create(undef, 0, @_); } sub inflate { - return IO::BaseInflate::_inf(__PACKAGE__, 'rfc1950', \$InflateError, @_); + 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.") + if ! 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 1; +} + + + +sub isZlibMagic +{ + my $buffer = shift ; + return 0 if length $buffer < ZLIB_HEADER_SIZE ; + my $hdr = unpack("n", $buffer) ; + return $hdr % 31 == 0 ; } +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__ @@ -103,34 +242,34 @@ B<WARNING -- This is a Beta release>. -This module provides a Perl interface that allows the reading of +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. +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. +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"; - inflate \%hash [,OPTS] - or die "inflate failed: $InflateError\n"; + The functional interface needs Perl5.005 or better. =head2 inflate $input => $output [, OPTS] -If the first parameter is not a hash reference C<inflate> expects -at least two parameters, C<$input> and C<$output>. + +C<inflate> expects at least two parameters, C<$input> and C<$output>. =head3 The C<$input> parameter @@ -160,13 +299,15 @@ from C<$$input>. =item An array reference -If C<$input> is an array reference, the input data will be read from each -element of the array in turn. The action taken by C<inflate> with -each element of the array will depend on the type of data stored -in it. You can mix and match any of the types defined in this list, -excluding other array or hash references. +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 data types before any data is uncompressed. +contains valid filenames before any data is uncompressed. + + =item An Input FileGlob string @@ -194,36 +335,28 @@ uncompressed data. This parameter can take one of these forms. =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. +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. +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 A Hash Reference - -If C<$output> is a hash reference, the uncompressed data will be written -to C<$output{$input}> as a scalar reference. +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. -When C<$output> is a hash reference, C<$input> must be either a filename or -list of filenames. Anything else is an error. =item An Array Reference -If C<$output> is an array reference, the uncompressed data will be pushed -onto the array. +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. =item An Output FileGlob @@ -238,60 +371,13 @@ string. Anything else is an error. If the C<$output> parameter is any other type, C<undef> will be returned. -=head2 inflate \%hash [, OPTS] - -If the first parameter is a hash reference, C<\%hash>, this will be used to -define both the source of compressed data and to control where the -uncompressed data is output. Each key/value pair in the hash defines a -mapping between an input filename, stored in the key, and an output -file/buffer, stored in the value. Although the input can only be a filename, -there is more flexibility to control the destination of the uncompressed -data. This is determined by the type of the value. Valid types are - -=over 5 - -=item undef - -If the value is C<undef> the uncompressed data will be written to the -value as a scalar reference. - -=item A filename - -If the value 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 value 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 the value is a scalar reference, the uncompressed data will be stored -in the buffer that is referenced by the scalar. - - -=item A Hash Reference - -If the value is a hash reference, the uncompressed data will be written -to C<$hash{$input}> as a scalar reference. - -=item An Array Reference -If C<$output> is an array reference, the uncompressed data will be pushed -onto the array. - -=back - -Any other type is a error. =head2 Notes When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the uncompressed input files/buffers will all be stored in -C<$output> as a single uncompressed stream. +file/buffer the uncompressed input files/buffers will all be stored +in C<$output> as a single uncompressed stream. @@ -305,8 +391,8 @@ L</"Constructor Options"> section below. =item AutoClose =E<gt> 0|1 -This option applies to any input or output data streams to C<inflate> -that are filehandles. +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 @@ -316,10 +402,27 @@ This parameter defaults to 0. +=item BinModeOut =E<gt> 0|1 + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + + + + + =item -Append =E<gt> 0|1 TODO +=item -MultiStream =E<gt> 0|1 + +Creates a new stream after each file. + +Defaults to 1. + =back @@ -392,11 +495,11 @@ The format of the constructor for IO::Uncompress::Inflate is shown below 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 +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>; @@ -470,8 +573,9 @@ 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. +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 -Transparent =E<gt> 0|1 @@ -482,20 +586,21 @@ This option defaults to 1. =item -BlockSize =E<gt> $num -When reading the compressed input data, IO::Uncompress::Inflate will read it in blocks -of C<$num> bytes. +When reading the compressed input data, IO::Uncompress::Inflate will read it in +blocks of C<$num> bytes. This option defaults to 4096. =item -InputLength =E<gt> $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. +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 +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. @@ -506,11 +611,11 @@ This option defaults to off. 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 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. +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. @@ -519,8 +624,8 @@ Defaults to 0. 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. +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. @@ -565,12 +670,12 @@ Usage is 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. +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. +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. =head2 read @@ -584,13 +689,13 @@ Usage is 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. +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. +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. =head2 getline @@ -635,19 +740,12 @@ TODO Usage is - $hdr = $z->getHeaderInfo() - -TODO - - - - - -This method returns a hash reference that contains the contents of each of the -header fields defined in RFC1950. - - + $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). @@ -800,7 +898,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005 Paul Marquess. All rights reserved. +Copyright (c) 2005-2006 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/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm b/ext/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm index 45cad1a5dc..756a10c163 100644 --- a/ext/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm +++ b/ext/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm @@ -3,34 +3,326 @@ package IO::Uncompress::RawInflate ; use strict ; use warnings; -use IO::Uncompress::Gunzip; + +use Compress::Zlib 2 ; +use Compress::Zlib::Common qw(:Status createSelfTiedObject); +use Compress::Zlib::ParseParameters ; + +use IO::Uncompress::Base ; +use UncompressPlugin::Inflate ; + + + require Exporter ; -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $RawInflateError); +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError); -$VERSION = '2.000_05'; +$VERSION = '2.000_07'; $RawInflateError = ''; -@ISA = qw(Exporter IO::BaseInflate); +@ISA = qw( Exporter IO::Uncompress::Base ); @EXPORT_OK = qw( $RawInflateError rawinflate ) ; -%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ; +%DEFLATE_CONSTANTS = (); +%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ; push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; Exporter::export_ok_tags('all'); - sub new { - my $pkg = shift ; - return IO::BaseInflate::new($pkg, 'rfc1951', undef, \$RawInflateError, 0, @_); + my $class = shift ; + my $obj = createSelfTiedObject($class, \$RawInflateError); + $obj->_create(undef, 0, @_); } sub rawinflate { - return IO::BaseInflate::_inf(__PACKAGE__, 'rfc1951', \$RawInflateError, @_); + 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) = UncompressPlugin::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 1 ; +} + +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}->count(); + + 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__ @@ -104,34 +396,34 @@ B<WARNING -- This is a Beta release>. -This module provides a Perl interface that allows the reading of +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. +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. +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"; - rawinflate \%hash [,OPTS] - or die "rawinflate failed: $RawInflateError\n"; + The functional interface needs Perl5.005 or better. =head2 rawinflate $input => $output [, OPTS] -If the first parameter is not a hash reference C<rawinflate> expects -at least two parameters, C<$input> and C<$output>. + +C<rawinflate> expects at least two parameters, C<$input> and C<$output>. =head3 The C<$input> parameter @@ -161,13 +453,15 @@ from C<$$input>. =item An array reference -If C<$input> is an array reference, the input data will be read from each -element of the array in turn. The action taken by C<rawinflate> with -each element of the array will depend on the type of data stored -in it. You can mix and match any of the types defined in this list, -excluding other array or hash references. +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 data types before any data is uncompressed. +contains valid filenames before any data is uncompressed. + + =item An Input FileGlob string @@ -195,36 +489,28 @@ uncompressed data. This parameter can take one of these forms. =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. +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. +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>. +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. -=item A Hash Reference - -If C<$output> is a hash reference, the uncompressed data will be written -to C<$output{$input}> as a scalar reference. - -When C<$output> is a hash reference, C<$input> must be either a filename or -list of filenames. Anything else is an error. - =item An Array Reference -If C<$output> is an array reference, the uncompressed data will be pushed -onto the array. +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. =item An Output FileGlob @@ -239,60 +525,13 @@ string. Anything else is an error. If the C<$output> parameter is any other type, C<undef> will be returned. -=head2 rawinflate \%hash [, OPTS] - -If the first parameter is a hash reference, C<\%hash>, this will be used to -define both the source of compressed data and to control where the -uncompressed data is output. Each key/value pair in the hash defines a -mapping between an input filename, stored in the key, and an output -file/buffer, stored in the value. Although the input can only be a filename, -there is more flexibility to control the destination of the uncompressed -data. This is determined by the type of the value. Valid types are - -=over 5 - -=item undef - -If the value is C<undef> the uncompressed data will be written to the -value as a scalar reference. -=item A filename - -If the value 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 value 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 the value is a scalar reference, the uncompressed data will be stored -in the buffer that is referenced by the scalar. - - -=item A Hash Reference - -If the value is a hash reference, the uncompressed data will be written -to C<$hash{$input}> as a scalar reference. - -=item An Array Reference - -If C<$output> is an array reference, the uncompressed data will be pushed -onto the array. - -=back - -Any other type is a error. =head2 Notes When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the uncompressed input files/buffers will all be stored in -C<$output> as a single uncompressed stream. +file/buffer the uncompressed input files/buffers will all be stored +in C<$output> as a single uncompressed stream. @@ -306,8 +545,8 @@ L</"Constructor Options"> section below. =item AutoClose =E<gt> 0|1 -This option applies to any input or output data streams to C<rawinflate> -that are filehandles. +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 @@ -317,10 +556,27 @@ This parameter defaults to 0. +=item BinModeOut =E<gt> 0|1 + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + + + + + =item -Append =E<gt> 0|1 TODO +=item -MultiStream =E<gt> 0|1 + +Creates a new stream after each file. + +Defaults to 1. + =back @@ -393,11 +649,11 @@ The format of the constructor for IO::Uncompress::RawInflate is shown below 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 +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>; @@ -465,8 +721,9 @@ 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. +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 -Transparent =E<gt> 0|1 @@ -477,20 +734,21 @@ This option defaults to 1. =item -BlockSize =E<gt> $num -When reading the compressed input data, IO::Uncompress::RawInflate will read it in blocks -of C<$num> bytes. +When reading the compressed input data, IO::Uncompress::RawInflate will read it in +blocks of C<$num> bytes. This option defaults to 4096. =item -InputLength =E<gt> $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. +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 +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. @@ -501,11 +759,11 @@ This option defaults to off. 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 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. +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. @@ -535,12 +793,12 @@ Usage is 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. +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. +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. =head2 read @@ -554,13 +812,13 @@ Usage is 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. +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. +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. =head2 getline @@ -605,17 +863,12 @@ TODO Usage is - $hdr = $z->getHeaderInfo() - -TODO - - - - - - - + $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). @@ -768,7 +1021,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005 Paul Marquess. All rights reserved. +Copyright (c) 2005-2006 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/Compress/Zlib/lib/IO/Uncompress/Unzip.pm b/ext/Compress/Zlib/lib/IO/Uncompress/Unzip.pm new file mode 100644 index 0000000000..df108a569e --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Uncompress/Unzip.pm @@ -0,0 +1,459 @@ +package IO::Uncompress::Unzip; + +require 5.004 ; + +# for RFC1952 + +use strict ; +use warnings; + +use IO::Uncompress::RawInflate ; +use Compress::Zlib::Common qw(createSelfTiedObject); +use UncompressPlugin::Identity; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError); + +$VERSION = '2.000_05'; +$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'); + + +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 Compress::Zlib::ParseParameters; + + + 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 $status = $self->_readZipHeader($magic) ; + + while (defined $status) + { + if (! defined $name || $status->{Name} eq $name) + { + return $status ; + } + + # skip the data + my $c = $status->{CompressedLength}; + my $buffer; + $self->smartReadExact(\$buffer, $c) + or return $self->saveErrorString(undef, "Truncated file"); + + # skip the trailer + $c = $status->{TrailerLength}; + $self->smartReadExact(\$buffer, $c) + or return $self->saveErrorString(undef, "Truncated file"); + + $self->chkTrailer($buffer) + or return $self->saveErrorString(undef, "Truncated file"); + + $status = $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) ; + if (*$self->{ZipData}{Streaming}) { + ($sig, $CRC32, $cSize, $uSize) = unpack("V V V V", $trailer) ; + return $self->TrailerError("Data Descriptor signature") + if $sig != 0x08074b50; + } + else { + ($CRC32, $cSize, $uSize) = + (*$self->{ZipData}{Crc32}, + *$self->{ZipData}{CompressedLen}, + *$self->{ZipData}{UnCompressedLen}); + } + + if (*$self->{Strict}) { + #return $self->TrailerError("CRC mismatch") + # if $CRC32 != *$self->{Uncomp}->crc32() ; + + my $exp_isize = *$self->{Uncomp}->compressedBytes(); + return $self->TrailerError("CSIZE mismatch. Got $cSize" + . ", expected $exp_isize") + if $cSize != $exp_isize ; + + $exp_isize = *$self->{Uncomp}->uncompressedBytes(); + return $self->TrailerError("USIZE mismatch. Got $uSize" + . ", expected $exp_isize") + if $uSize != $exp_isize ; + } + + # check for central directory or end of central directory + while (1) + { + my $magic ; + $self->smartReadExact(\$magic, 4); + my $sig = unpack("V", $magic) ; + + if ($sig == 0x02014b50) + { + $self->skipCentralDirectory($magic); + } + elsif ($sig == 0x06054b50) + { + $self->skipEndCentralDirectory($magic); + last; + } + else + { + # put the data back + $self->pushBack($magic) ; + last; + } + } + + return 1 ; +} + +sub skipCentralDirectory +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 46 - 4) + or return $self->HeaderError("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->HeaderError("xxx"); + $keep .= $filename ; + } + + if ($extra_length) + { + $self->smartReadExact(\$extraField, $extra_length) + or return $self->HeaderError("xxx"); + $keep .= $extraField ; + } + + if ($comment_length) + { + $self->smartReadExact(\$comment, $comment_length) + or return $self->HeaderError("xxx"); + $keep .= $comment ; + } + + return 1 ; +} + +sub skipEndCentralDirectory +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 22 - 4) + or return $self->HeaderError("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->HeaderError("xxx"); + $keep .= $comment ; + } + + return 1 ; +} + + + + +sub _isZipMagic +{ + my $buffer = shift ; + return 0 if length $buffer < 4 ; + my $sig = unpack("V", $buffer) ; + return $sig == 0x04034b50 ; +} + + +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 = unpack ("V", substr($buffer, 18-4, 4)); + my $uncompressedLength = 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 $streamingMode = ($gpFlag & 0x08) ? 1 : 0 ; + + return $self->HeaderError("Streamed Stored content not supported") + if $streamingMode && $compressedMethod == 0 ; + + *$self->{ZipData}{Streaming} = $streamingMode; + + if (! $streamingMode) { + *$self->{ZipData}{Streaming} = 0; + *$self->{ZipData}{Crc32} = $crc32; + *$self->{ZipData}{CompressedLen} = $compressedLength; + *$self->{ZipData}{UnCompressedLen} = $uncompressedLength; + } + + if ($filename_length) + { + $self->smartReadExact(\$filename, $filename_length) + or return $self->HeaderError("xxx"); + $keep .= $filename ; + } + + if ($extra_length) + { + $self->smartReadExact(\$extraField, $extra_length) + or return $self->HeaderError("xxx"); + $keep .= $extraField ; + } + + *$self->{CompressedInputLengthRemaining} = + *$self->{CompressedInputLength} = $compressedLength; + + if ($compressedMethod == 8) + { + *$self->{Type} = 'zip'; + } + elsif ($compressedMethod == 0) + { + # TODO -- add support for reading uncompressed + + *$self->{Type} = 'zipStored'; + + my $obj = UncompressPlugin::Identity::mkUncompObject(# $got->value('CRC32'), + # $got->value('ADLER32'), + ); + + *$self->{Uncomp} = $obj; + + } + else + { + return $self->HeaderError("Unsupported Compression format $compressedMethod"); + } + + return { + 'Type' => 'zip', + 'FingerprintLength' => 2, + #'HeaderLength' => $compressedMethod == 8 ? length $keep : 0, + 'HeaderLength' => length $keep, + 'TrailerLength' => $streamingMode ? 16 : 0, + 'Header' => $keep, + 'CompressedLength' => $compressedLength , + 'UncompressedLength' => $uncompressedLength , + 'CRC32' => $crc32 , + 'Name' => $filename, + 'Time' => _dosToUnixTime($lastModTime), + 'Stream' => $streamingMode, + + 'MethodID' => $compressedMethod, + 'MethodName' => $compressedMethod == 8 + ? "Deflated" + : $compressedMethod == 0 + ? "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' => $EXTRA, +# 'ExtraField' => [ @EXTRA ], + + + } +} + +# 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__ + diff --git a/ext/Compress/Zlib/lib/UncompressPlugin/Identity.pm b/ext/Compress/Zlib/lib/UncompressPlugin/Identity.pm new file mode 100644 index 0000000000..3041a9f5a2 --- /dev/null +++ b/ext/Compress/Zlib/lib/UncompressPlugin/Identity.pm @@ -0,0 +1,93 @@ +package UncompressPlugin::Identity; + +use warnings; +use strict; + +use Compress::Zlib::Common qw(:Status); + +our ($VERSION); + +$VERSION = '2.000_05'; + +use Compress::Zlib (); + +sub mkUncompObject +{ + my $crc32 = 1; #shift ; + my $adler32 = shift; + + bless { 'CompSize' => 0, + 'UnCompSize' => 0, + 'wantCRC32' => $crc32, + 'CRC32' => Compress::Zlib::crc32(''), + 'wantADLER32'=> $adler32, + 'ADLER32' => Compress::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::Zlib::crc32($_[0], $self->{CRC32}) + if $self->{wantCRC32}; + + $self->{ADLER32} = Compress::Zlib::adler32($_[0], $self->{ADLER32}) + if $self->{wantADLER32}; + + ${ $_[1] } .= ${ $_[0] }; + } + + return STATUS_ENDSTREAM if $eof; + return STATUS_OK ; +} + +sub reset +{ + 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/Compress/Zlib/lib/UncompressPlugin/Inflate.pm b/ext/Compress/Zlib/lib/UncompressPlugin/Inflate.pm new file mode 100644 index 0000000000..ec3a148258 --- /dev/null +++ b/ext/Compress/Zlib/lib/UncompressPlugin/Inflate.pm @@ -0,0 +1,160 @@ +package UncompressPlugin::Inflate; + +use strict; +use warnings; + +use Compress::Zlib::Common qw(:Status); +use Compress::Zlib qw(Z_OK Z_DATA_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); + +our ($VERSION); +$VERSION = '2.000_05'; + + + +sub mkUncompObject +{ + my $crc32 = shift || 1; + my $adler32 = shift || 1; + my $scan = shift || 0; + + my $inflate ; + my $status ; + + if ($scan) + { + ($inflate, $status) = new Compress::Zlib::InflateScan + CRC32 => $crc32, + ADLER32 => $adler32, + WindowBits => - MAX_WBITS ; + } + else + { + ($inflate, $status) = new Compress::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' => '', + }, 'CompressPlugin::Deflate'; +} + +1; + + +__END__ + diff --git a/ext/Compress/Zlib/pod/FAQ.pod b/ext/Compress/Zlib/pod/FAQ.pod index 9fb270230d..27660f7459 100644 --- a/ext/Compress/Zlib/pod/FAQ.pod +++ b/ext/Compress/Zlib/pod/FAQ.pod @@ -11,21 +11,21 @@ Common questions answered. =head2 Compatibility with Unix compress/uncompress. -Although C<Compress::Zlib> has a pair of functions called C<compress> -and C<uncompress>, they are I<not> the same as the Unix programs of the -same name. The C<Compress::Zlib> library is not compatible with Unix +Although C<Compress::Zlib> has a pair of functions called C<compress> and +C<uncompress>, they are I<not> the same as the Unix programs of the same +name. The C<Compress::Zlib> library is not compatible with Unix C<compress>. -If you have the C<uncompress> program available, you can use this to -read compressed files +If you have the C<uncompress> program available, you can use this to read +compressed files open F, "uncompress -c $filename |"; while (<F>) { ... -If you have the C<gunzip> program available, you can use this to read -compressed files +Alternatively, if you have the C<gunzip> program available, you can use +this to read compressed files open F, "gunzip -c $filename |"; while (<F>) @@ -42,14 +42,14 @@ available =head2 Accessing .tar.Z files -The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via -the C<IO::Zlib> module) to access tar files that have been compressed -with C<gzip>. Unfortunately tar files compressed with the Unix C<compress> +The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via the +C<IO::Zlib> module) to access tar files that have been compressed with +C<gzip>. Unfortunately tar files compressed with the Unix C<compress> utility cannot be read by C<Compress::Zlib> and so cannot be directly accesses by C<Archive::Tar>. -If the C<uncompress> or C<gunzip> programs are available, you can use -one of these workarounds to read C<.tar.Z> files from C<Archive::Tar> +If the C<uncompress> or C<gunzip> programs are available, you can use one +of these workarounds to read C<.tar.Z> files from C<Archive::Tar> Firstly with C<uncompress> @@ -88,6 +88,9 @@ write a C<.tar.Z> file =head2 Accessing Zip Files + + + Although it is possible (with some effort on your part) to use this module to access .zip files, there is a module on CPAN that will do all the hard work for you. Check out the C<Archive::Zip> module on CPAN at @@ -102,12 +105,14 @@ be aware of. =item 1. -When calling B<inflateInit> or B<deflateInit> the B<WindowBits> parameter -must be set to C<-MAX_WBITS>. This disables the creation of the zlib -header. +When calling B<Compress::Zlib::Inflate::new> or +B<Compress::Zlib::Deflate::new> the B<WindowBits> parameter must be set to +C<-MAX_WBITS>. This enables the creation of an RFC1951 compressed data +stream. =item 2. +If you are using zlib older than 1.2.0, The zlib function B<inflate>, and so the B<inflate> method supplied in this module, assume that there is at least one trailing byte after the compressed data stream. Normally this isn't a problem because both @@ -129,8 +134,9 @@ after the compressed data stream. =head2 Zlib Library Version Support -By default C<Compress::Zlib> will build with a private copy of version 1.2.3 of the zlib library. (See the F<README> file for details of how -to override this behavior) +By default C<Compress::Zlib> will build with a private copy of version +1.2.3 of the zlib library. (See the F<README> file for details of +how to override this behaviour) If you decide to use a different version of the zlib library, you need to be aware of the following issues @@ -143,8 +149,9 @@ First off, you must have zlib 1.0.5 or better. =item * -You need to have zlib 1.2.1 or better if you want to use the C<-Merge> option -with C<IO::Compress::Gzip>, C<IO::Compress::Deflate> and C<IO::Compress::RawDeflate>. +You need to have zlib 1.2.1 or better if you want to use the C<-Merge> +option with C<IO::Compress::Gzip>, C<IO::Compress::Deflate> and +C<IO::Compress::RawDeflate>. @@ -188,7 +195,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005 Paul Marquess. All rights reserved. +Copyright (c) 2005-2006 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/Compress/Zlib/ppport.h b/ext/Compress/Zlib/ppport.h index a3f80aa3d4..94d2190ff6 100644 --- a/ext/Compress/Zlib/ppport.h +++ b/ext/Compress/Zlib/ppport.h @@ -4,10 +4,10 @@ /* ---------------------------------------------------------------------- - ppport.h -- Perl/Pollution/Portability Version 3.02 + ppport.h -- Perl/Pollution/Portability Version 3.06 Automatically created by Devel::PPPort running under - perl 5.009002 on Wed Sep 8 21:34:54 2004. + perl 5.009003 on Mon Jan 9 10:21:52 2006. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. @@ -22,7 +22,7 @@ SKIP =head1 NAME -ppport.h - Perl/Pollution/Portability version 3.02 +ppport.h - Perl/Pollution/Portability version 3.06 =head1 SYNOPSIS @@ -44,6 +44,7 @@ ppport.h - Perl/Pollution/Portability version 3.02 --list-provided list provided API --list-unsupported list unsupported API + --api-info=name show Perl API portability information =head1 COMPATIBILITY @@ -124,6 +125,12 @@ Lists the API elements that are known not to be supported by F<ppport.h> and below which version of Perl they probably won't be available or work. +=head2 --api-info=I<name> + +Show portability information for API elements matching I<name>. +If I<name> is surrounded by slashes, it is interpreted as a regular +expression. + =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible @@ -238,6 +245,22 @@ the C<--diff> option: This would output context diffs with 10 lines of context. +To display portability information for the C<newSVpvn> function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + =head1 BUGS If this version of F<ppport.h> is causing failure during @@ -280,7 +303,7 @@ module from CPAN. =head1 COPYRIGHT -Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz. +Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. @@ -314,7 +337,7 @@ eval { Getopt::Long::GetOptions(\%opt, qw( help quiet diag! hints! changes! cplusplus patch=s copy=s diff=s compat-version=s - list-provided list-unsupported + list-provided list-unsupported api-info=s )) or usage(); }; @@ -749,6 +772,10 @@ UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| @@ -879,8 +906,10 @@ dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p +dXCPT|5.009002||p dXSARGS||| dXSI32||| +dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| @@ -891,7 +920,6 @@ debprof||| debstackptrs||5.007003| debstack||5.007003| deb||5.007003|v -default_protect|||v del_he||| del_sv||| del_xiv||| @@ -1070,7 +1098,9 @@ gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod||| gv_fetchmeth||| +gv_fetchpvn_flags||5.009002| gv_fetchpv||| +gv_fetchsv||5.009002| gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| @@ -1146,6 +1176,7 @@ isLOWER||| isSPACE||| isUPPER||| is_an_int||| +is_gv_magical_sv||| is_gv_magical||| is_handle_constructor||| is_lvalue_sub||5.007001| @@ -1468,6 +1499,8 @@ op_const_sv||| op_dump||5.006000| op_free||| op_null||5.007002| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| open_script||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p @@ -1645,6 +1678,7 @@ savepv||| savesharedpv||5.007003| savestack_grow_cnt||5.008001| savestack_grow||| +savesvpv||5.009002| sawparens||| scalar_mod_type||| scalarboolean||| @@ -1910,14 +1944,10 @@ uvchr_to_utf8||5.007001| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| -vcall_body||| -vcall_list_body||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| -vdefault_protect||| vdie||| -vdocatch_body||| vform||5.006000| visit||| vivify_defelem||| @@ -1927,8 +1957,6 @@ vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| -vparse_body||| -vrun_body||| vstringify||5.009000| vwarner||5.006000| vwarn||5.006000| @@ -1985,6 +2013,41 @@ while (<DATA>) { $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "$hints{$f}" if exists $hints{$f}; + $info++; + } + unless ($info) { + print "No portability information available.\n"; + } + $count++; + } + if ($count > 0) { + print "\n"; + } + else { + print "Found no API matching '$opt{'api-info'}'.\n"; + } + exit 0; +} + if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { @@ -2969,14 +3032,16 @@ __DATA__ /* Replace: 0 */ #endif -#ifdef HASATTRIBUTE -# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) -# define PERL_UNUSED_DECL +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif # else -# define PERL_UNUSED_DECL __attribute__((unused)) +# define PERL_UNUSED_DECL # endif -#else -# define PERL_UNUSED_DECL #endif #ifndef NOOP # define NOOP (void)0 @@ -3165,6 +3230,9 @@ typedef NVTYPE NV; #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif #ifndef dTHR # define dTHR dNOOP #endif @@ -3382,8 +3450,6 @@ DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) #endif #endif -#ifndef START_MY_CXT - /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use @@ -3406,6 +3472,8 @@ DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) +#ifndef START_MY_CXT + /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ @@ -3437,13 +3505,6 @@ DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) -/* Clones the per-interpreter data. */ -#define MY_CXT_CLONE \ - dMY_CXT_SV; \ - my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ - Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ - sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) - /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) @@ -3457,13 +3518,25 @@ DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + #else /* single interpreter */ +#ifndef START_MY_CXT + #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP -#define MY_CXT_CLONE NOOP #define MY_CXT my_cxt #define pMY_CXT void @@ -3473,10 +3546,14 @@ DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) #define aMY_CXT_ #define _aMY_CXT -#endif - #endif /* START_MY_CXT */ +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" @@ -3510,8 +3587,7 @@ DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) #ifndef SvPV_nolen -/* #if defined(NEED_sv_2pv_nolen) */ -#if 1 +#if defined(NEED_sv_2pv_nolen) static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); static #else @@ -3524,8 +3600,7 @@ extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); #define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a) #define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen) -/* #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) */ -#if 1 +#if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv) @@ -3612,7 +3687,7 @@ DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) # define sv_pvn(sv, len) SvPV(sv, len) #endif -/* Hint: sv_pvn +/* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ #ifndef sv_pvn_force @@ -4800,6 +4875,22 @@ DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) #endif #endif +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ diff --git a/ext/Compress/Zlib/t/01version.t b/ext/Compress/Zlib/t/01version.t index 255d3aa9a9..b71291882e 100644 --- a/ext/Compress/Zlib/t/01version.t +++ b/ext/Compress/Zlib/t/01version.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } diff --git a/ext/Compress/Zlib/t/02zlib.t b/ext/Compress/Zlib/t/02zlib.t index eda3f855c7..f563308e62 100644 --- a/ext/Compress/Zlib/t/02zlib.t +++ b/ext/Compress/Zlib/t/02zlib.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } diff --git a/ext/Compress/Zlib/t/03zlib-v1.t b/ext/Compress/Zlib/t/03zlib-v1.t index 093052045f..cb88653402 100644 --- a/ext/Compress/Zlib/t/03zlib-v1.t +++ b/ext/Compress/Zlib/t/03zlib-v1.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } diff --git a/ext/Compress/Zlib/t/04def.t b/ext/Compress/Zlib/t/04def.t deleted file mode 100644 index fb9e4bd132..0000000000 --- a/ext/Compress/Zlib/t/04def.t +++ /dev/null @@ -1,1540 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib"); - } -} - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use ZlibTestUtils; - -BEGIN -{ - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 1769 + $extra ; - - use_ok('Compress::Zlib', 2) ; - - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - - use_ok('IO::Compress::Deflate', qw($DeflateError)) ; - use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; - - use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; - use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; - -} - -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - - -our ($UncompressClass); - - -sub myGZreadFile -{ - my $filename = shift ; - my $init = shift ; - - - my $fil = new $UncompressClass $filename, - -Strict => 1, - -Append => 1 - ; - - my $data = ''; - $data = $init if defined $init ; - 1 while $fil->read($data) > 0; - - $fil->close ; - return $data ; -} - -# Check zlib_version and ZLIB_VERSION are the same. -is Compress::Zlib::zlib_version, ZLIB_VERSION, - "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; - - - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate') -{ - - title "Testing $CompressClass"; - - # Buffer not writable - eval qq[\$a = new $CompressClass(\\1) ;] ; - like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ; - - my $out = "" ; - eval qq[\$a = new $CompressClass \$out ;] ; - like $@, mkEvalErr("^$CompressClass: output filename is undef or null string"); - - $out = undef ; - eval qq[\$a = new $CompressClass \$out ;] ; - like $@, mkEvalErr("^$CompressClass: output filename is undef or null string"); - - my $x ; - my $gz = new $CompressClass(\$x); - - foreach my $name (qw(read readline getc)) - { - eval " \$gz->$name() " ; - like $@, mkEvalErr("^$name Not Available: File opened only for output"); - } - - eval ' $gz->write({})' ; - like $@, mkEvalErr("^${CompressClass}::write: not a scalar reference"); - #like $@, mkEvalErr("^${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref"); - - eval ' $gz->syswrite("abc", 1, 5)' ; - like $@, mkEvalErr("^${CompressClass}::write: offset outside string"); - - eval ' $gz->syswrite("abc", 1, -4)' ; - like $@, mkEvalErr("^${CompressClass}::write: offset outside string"); -} - - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - title "Testing $UncompressClass"; - - my $out = "" ; - eval qq[\$a = new $UncompressClass \$out ;] ; - like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string"); - - $out = undef ; - eval qq[\$a = new $UncompressClass \$out ;] ; - like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string"); - - my $lex = new LexFile my $name ; - - ok ! -e $name, " $name does not exist"; - - eval qq[\$a = new $UncompressClass "$name" ;] ; - is $$UnError, "input file '$name' does not exist"; - - my $gc ; - my $guz = new $CompressClass(\$gc); - $guz->write("abc") ; - $guz->close(); - - my $x ; - my $gz = new $UncompressClass(\$gc); - - foreach my $name (qw(print printf write)) - { - eval " \$gz->$name() " ; - like $@, mkEvalErr("^$name Not Available: File opened only for intput"); - } - -} - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $ErrorUnc = getErrorRef($UncompressClass); - - - title "Testing $CompressClass and $UncompressClass"; - - { - my ($a, $x, @x) = ("","","") ; - - # Buffer not a scalar reference - eval qq[\$a = new $CompressClass \\\@x ;] ; - like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref"); - - # Buffer not a scalar reference - eval qq[\$a = new $UncompressClass \\\@x ;] ; - like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref"); - } - - foreach my $Type ( $CompressClass, $UncompressClass) - { - # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate - - my ($a, $x, @x) = ("","","") ; - - # Odd number of parameters - eval qq[\$a = new $Type "abc", -Output ] ; - like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1"); - - # Unknown parameter - eval qq[\$a = new $Type "anc", -Fred => 123 ;] ; - like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred"); - - # no in or out param - eval qq[\$a = new $Type ;] ; - like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter"); - - } - - - { - # write a very simple compressed file - # and read back - #======================================== - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - my $x ; - ok $x = new $CompressClass $name ; - - ok $x->write($hello), "write" ; - ok $x->flush(Z_FINISH), "flush"; - ok $x->close, "close" ; - } - - { - my $uncomp; - ok my $x = new $UncompressClass $name, -Append => 1 ; - - my $len ; - 1 while ($len = $x->read($uncomp)) > 0 ; - - is $len, 0, "read returned 0"; - - ok $x->close ; - is $uncomp, $hello ; - } - } - - { - # write a very simple compressed file - # and read back - #======================================== - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - my $x ; - ok $x = new $CompressClass $name ; - - is $x->write(''), 0, "Write empty string is ok"; - is $x->write(undef), 0, "Write undef is ok"; - ok $x->write($hello), "Write ok" ; - ok $x->close, "Close ok" ; - } - - { - my $uncomp; - my $x = new $UncompressClass $name ; - ok $x, "creates $UncompressClass $name" ; - - my $data = ''; - $data .= $uncomp while $x->read($uncomp) > 0 ; - - ok $x->close, "close ok" ; - is $data, $uncomp,"expected output" ; - } - } - - - { - # write a very simple file with using an IO filehandle - # and read back - #======================================== - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - my $fh = new IO::File ">$name" ; - ok $fh, "opened file $name ok"; - my $x = new $CompressClass $fh ; - ok $x, " created $CompressClass $fh" ; - - is $x->fileno(), fileno($fh), "fileno match" ; - is $x->write(''), 0, "Write empty string is ok"; - is $x->write(undef), 0, "Write undef is ok"; - ok $x->write($hello), "write ok" ; - ok $x->flush(), "flush"; - ok $x->close,"close" ; - $fh->close() ; - } - - my $uncomp; - { - my $x ; - ok my $fh1 = new IO::File "<$name" ; - ok $x = new $UncompressClass $fh1, -Append => 1 ; - ok $x->fileno() == fileno $fh1 ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close ; - } - - ok $hello eq $uncomp ; - } - - { - # write a very simple file with using a glob filehandle - # and read back - #======================================== - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - title "$CompressClass: Input from typeglob filehandle"; - ok open FH, ">$name" ; - - my $x = new $CompressClass *FH ; - ok $x, " create $CompressClass" ; - - is $x->fileno(), fileno(*FH), " fileno" ; - is $x->write(''), 0, " Write empty string is ok"; - is $x->write(undef), 0, " Write undef is ok"; - ok $x->write($hello), " Write ok" ; - ok $x->flush(), " Flush"; - ok $x->close, " Close" ; - close FH; - } - - my $uncomp; - { - title "$UncompressClass: Input from typeglob filehandle, append output"; - my $x ; - ok open FH, "<$name" ; - ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0 ; - is $x->fileno(), fileno FH, " fileno ok" ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close, " close" ; - } - - is $uncomp, $hello, " expected output" ; - } - - { - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - title "Outout to stdout via '-'" ; - - open(SAVEOUT, ">&STDOUT"); - my $dummy = fileno SAVEOUT; - open STDOUT, ">$name" ; - - my $x = new $CompressClass '-' ; - $x->write($hello); - $x->close; - - open(STDOUT, ">&SAVEOUT"); - - ok 1, " wrote to stdout" ; - } - - { - title "Input from stdin via filename '-'"; - - my $x ; - my $uncomp ; - my $stdinFileno = fileno(STDIN); - # open below doesn't return 1 sometines on XP - open(SAVEIN, "<&STDIN"); - ok open(STDIN, "<$name"), " redirect STDIN"; - my $dummy = fileno SAVEIN; - $x = new $UncompressClass '-'; - ok $x, " created object" ; - is $x->fileno(), $stdinFileno, " fileno ok" ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close, " close" ; - open(STDIN, "<&SAVEIN"); - is $hello, $uncomp, " expected output" ; - } - } - - { - # write a compressed file to memory - # and read back - #======================================== - - my $name = "test.gz" ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - my $buffer ; - { - my $x ; - ok $x = new $CompressClass(\$buffer) ; - - ok ! defined $x->fileno() ; - is $x->write(''), 0, "Write empty string is ok"; - is $x->write(undef), 0, "Write undef is ok"; - ok $x->write($hello) ; - ok $x->flush(); - ok $x->close ; - - writeFile($name, $buffer) ; - #is anyUncompress(\$buffer), $hello, " any ok"; - } - - my $keep = $buffer ; - my $uncomp; - { - my $x ; - ok $x = new $UncompressClass(\$buffer, Append => 1) ; - - ok ! defined $x->fileno() ; - 1 while $x->read($uncomp) > 0 ; - - ok $x->close ; - } - - is $uncomp, $hello ; - ok $buffer eq $keep ; - } - - if ($CompressClass ne 'RawDeflate') - { - # write empty file - #======================================== - - my $buffer = ''; - { - my $x ; - ok $x = new $CompressClass(\$buffer) ; - ok $x->close ; - - } - - my $keep = $buffer ; - my $uncomp= ''; - { - my $x ; - ok $x = new $UncompressClass(\$buffer, Append => 1) ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close ; - } - - ok $uncomp eq '' ; - ok $buffer eq $keep ; - - } - - { - # write a larger file - #======================================== - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - my $input = '' ; - my $contents = '' ; - - { - my $x = new $CompressClass $name ; - ok $x, " created $CompressClass object"; - - ok $x->write($hello), " write ok" ; - $input .= $hello ; - ok $x->write("another line"), " write ok" ; - $input .= "another line" ; - # all characters - foreach (0 .. 255) - { $contents .= chr int $_ } - # generate a long random string - foreach (1 .. 5000) - { $contents .= chr int rand 256 } - - ok $x->write($contents), " write ok" ; - $input .= $contents ; - ok $x->close, " close ok" ; - } - - ok myGZreadFile($name) eq $input ; - my $x = readFile($name) ; - #print "length " . length($x) . " \n"; - } - - { - # embed a compressed file in another file - #================================ - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - my $header = "header info\n" ; - my $trailer = "trailer data\n" ; - - { - my $fh ; - ok $fh = new IO::File ">$name" ; - print $fh $header ; - my $x ; - ok $x = new $CompressClass $fh, - -AutoClose => 0 ; - - ok $x->binmode(); - ok $x->write($hello) ; - ok $x->close ; - print $fh $trailer ; - $fh->close() ; - } - - my ($fil, $uncomp) ; - my $fh1 ; - ok $fh1 = new IO::File "<$name" ; - # skip leading junk - my $line = <$fh1> ; - ok $line eq $header ; - - ok my $x = new $UncompressClass $fh1 ; - ok $x->binmode(); - my $got = $x->read($uncomp); - - ok $uncomp eq $hello ; - my $rest ; - read($fh1, $rest, 5000); - is ${ $x->trailingData() } . $rest, $trailer ; - #print ${ $x->trailingData() } . $rest ; - - } - - { - # Write - # these tests come almost 100% from IO::String - - my $lex = new LexFile my $name ; - - my $io = $CompressClass->new($name); - - is $io->tell(), 0, " tell returns 0"; ; - - my $heisan = "Heisan\n"; - $io->print($heisan) ; - - ok ! $io->eof(), " ! eof"; - - is $io->tell(), length($heisan), " tell is " . length($heisan) ; - - $io->print("a", "b", "c"); - - { - local($\) = "\n"; - $io->print("d", "e"); - local($,) = ","; - $io->print("f", "g", "h"); - } - - { - local($\) ; - $io->print("D", "E"); - local($,) = "."; - $io->print("F", "G", "H"); - } - - my $foo = "1234567890"; - - is $io->syswrite($foo, length($foo)), length($foo), " syswrite ok" ; - if ( $[ < 5.6 ) - { is $io->syswrite($foo, length $foo), length $foo, " syswrite ok" } - else - { is $io->syswrite($foo), length $foo, " syswrite ok" } - is $io->syswrite($foo, length($foo)), length $foo, " syswrite ok"; - is $io->write($foo, length($foo), 5), 5, " write 5"; - is $io->write("xxx\n", 100, -1), 1, " write 1"; - - for (1..3) { - $io->printf("i(%d)", $_); - $io->printf("[%d]\n", $_); - } - $io->print("\n"); - - $io->close ; - - ok $io->eof(), " eof"; - - is myGZreadFile($name), "Heisan\nabcde\nf,g,h\nDEF.G.H" . - ("1234567890" x 3) . "67890\n" . - "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; - - - } - - { - # Read - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - my %opts = () ; - %opts = (CRC32 => 1, Adler32 => 1) - if $CompressClass ne "IO::Compress::Gzip"; - my $iow = new $CompressClass $name, %opts; - $iow->print($str) ; - $iow->close ; - - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name ; - - ok ! $io->eof; - is $io->tell(), 0 ; - #my @lines = <$io>; - my @lines = $io->getlines(); - is @lines, 6 - or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; - is $lines[1], "of a paragraph\n" ; - is join('', @lines), $str ; - is $., 6; - is $io->tell(), length($str) ; - - ok $io->eof; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined($io->getline) || - defined($io->getc) || - $io->read($buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = $io->getline(); - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines(); - ok $io->eof; - ok @lines == 2 - or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# $lines[0]\n"; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (my $a = $io->getline()) { - push(@lines, $a); - $err++ if $. != ++$no; - } - - ok $err == 0 ; - ok $io->eof; - - ok @lines == 3 - or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test read - - { - my $io = $UncompressClass->new($name); - - - eval { $io->read(1) } ; - like $@, mkErr("buffer parameter is read-only"); - - is $io->read($buf, 0), 0, "Requested 0 bytes" ; - - ok $io->read($buf, 3) == 3 ; - ok $buf eq "Thi"; - - ok $io->sysread($buf, 3, 2) == 3 ; - ok $buf eq "Ths i" - or print "# [$buf]\n" ;; - ok ! $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - } - - { - # Read from non-compressed file - - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - writeFile($name, $str); - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name, -Transparent => 1 ; - - ok defined $io; - ok ! $io->eof; - ok $io->tell() == 0 ; - my @lines = $io->getlines(); - ok @lines == 6; - ok $lines[1] eq "of a paragraph\n" ; - ok join('', @lines) eq $str ; - ok $. == 6; - ok $io->tell() == length($str) ; - - ok $io->eof; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined($io->getline) || - defined($io->getc) || - $io->read($buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = $io->getline; - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines; - ok $io->eof; - ok @lines == 2 - or print "# exected 2 lines, got " . scalar(@lines) . "\n"; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# [$lines[0]]\n" ; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (my $a = $io->getline) { - push(@lines, $a); - $err++ if $. != ++$no; - } - - ok $err == 0 ; - ok $io->eof; - - ok @lines == 3 ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test read - - { - my $io = $UncompressClass->new($name); - - ok $io->read($buf, 3) == 3 ; - ok $buf eq "Thi"; - - ok $io->sysread($buf, 3, 2) == 3 ; - ok $buf eq "Ths i"; - ok ! $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - - } - - { - # Vary the length parameter in a read - - my $str = <<EOT; -x -x -This is an example -of a paragraph - - -and a single line. - -EOT - $str = $str x 100 ; - - - foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) - { - foreach my $trans (0, 1) - { - foreach my $append (0, 1) - { - title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; - - my $lex = new LexFile my $name ; - - if ($trans) { - writeFile($name, $str) ; - } - else { - my $iow = new $CompressClass $name; - $iow->print($str) ; - $iow->close ; - } - - - my $io = $UncompressClass->new($name, - -Append => $append, - -Transparent => $trans); - - my $buf; - - is $io->tell(), 0; - - if ($append) { - 1 while $io->read($buf, $bufsize) > 0; - } - else { - my $tmp ; - $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; - } - is length $buf, length $str; - ok $buf eq $str ; - ok ! $io->error() ; - ok $io->eof; - } - } - } - } - - foreach my $file (0, 1) - { - foreach my $trans (0, 1) - { - title "seek tests - file $file trans $trans" ; - - my $buffer ; - my $buff ; - my $lex = new LexFile my $name ; - - my $first = "beginning" ; - my $last = "the end" ; - - if ($trans) - { - $buffer = $first . "\x00" x 10 . $last; - writeFile($name, $buffer); - } - else - { - my $output ; - if ($file) - { - $output = $name ; - } - else - { - $output = \$buffer; - } - - my $iow = new $CompressClass $output ; - $iow->print($first) ; - ok $iow->seek(5, SEEK_CUR) ; - ok $iow->tell() == length($first)+5; - ok $iow->seek(0, SEEK_CUR) ; - ok $iow->tell() == length($first)+5; - ok $iow->seek(length($first)+10, SEEK_SET) ; - ok $iow->tell() == length($first)+10; - - $iow->print($last) ; - $iow->close ; - } - - my $input ; - if ($file) - { - $input = $name ; - } - else - { - $input = \$buffer ; - } - - ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ; - - my $io = $UncompressClass->new($input, Strict => 1); - ok $io->seek(length($first), SEEK_CUR) ; - ok ! $io->eof; - is $io->tell(), length($first); - - ok $io->read($buff, 5) ; - is $buff, "\x00" x 5 ; - is $io->tell(), length($first) + 5; - - ok $io->seek(0, SEEK_CUR) ; - my $here = $io->tell() ; - is $here, length($first)+5; - - ok $io->seek($here+5, SEEK_SET) ; - is $io->tell(), $here+5 ; - ok $io->read($buff, 100) ; - ok $buff eq $last ; - ok $io->eof; - } - } - - { - title "seek error cases" ; - - my $b ; - my $a = new $CompressClass(\$b) ; - - ok ! $a->error() ; - eval { $a->seek(-1, 10) ; }; - like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter"); - - eval { $a->seek(-1, SEEK_END) ; }; - like $@, mkErr("^${CompressClass}::seek: cannot seek backwards"); - - $a->write("fred"); - $a->close ; - - - my $u = new $UncompressClass(\$b) ; - - eval { $u->seek(-1, 10) ; }; - like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter"); - - eval { $u->seek(-1, SEEK_END) ; }; - like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed"); - - eval { $u->seek(-1, SEEK_CUR) ; }; - like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards"); - } - - foreach my $fb (qw(filename buffer filehandle)) - { - foreach my $append (0, 1) - { - { - title "$CompressClass -- Append $append, Output to $fb" ; - - my $lex = new LexFile my $name ; - - my $already = 'already'; - my $buffer = $already; - my $output; - - if ($fb eq 'buffer') - { $output = \$buffer } - elsif ($fb eq 'filename') - { - $output = $name ; - writeFile($name, $buffer); - } - elsif ($fb eq 'filehandle') - { - $output = new IO::File ">$name" ; - print $output $buffer; - } - - my $a = new $CompressClass($output, Append => $append) ; - ok $a, " Created $CompressClass"; - my $string = "appended"; - $a->write($string); - $a->close ; - - my $data ; - if ($fb eq 'buffer') - { - $data = $buffer; - } - else - { - $output->close - if $fb eq 'filehandle'; - $data = readFile($name); - } - - if ($append || $fb eq 'filehandle') - { - is substr($data, 0, length($already)), $already, " got prefix"; - substr($data, 0, length($already)) = ''; - } - - - my $uncomp; - my $x = new $UncompressClass(\$data, Append => 1) ; - ok $x, " created $UncompressClass"; - - my $len ; - 1 while ($len = $x->read($uncomp)) > 0 ; - - $x->close ; - is $uncomp, $string, ' Got uncompressed data' ; - - } - } - } - - foreach my $type (qw(buffer filename filehandle)) - { - title "$UncompressClass -- InputLength, read from $type"; - - my $compressed ; - my $string = "some data"; - my $c = new $CompressClass(\$compressed); - $c->write($string); - $c->close(); - - my $appended = "append"; - my $comp_len = length $compressed; - $compressed .= $appended; - - my $lex = new LexFile my $name ; - my $input ; - writeFile ($name, $compressed); - - if ($type eq 'buffer') - { - $input = \$compressed; - } - if ($type eq 'filename') - { - $input = $name; - } - elsif ($type eq 'filehandle') - { - my $fh = new IO::File "<$name" ; - ok $fh, "opened file $name ok"; - $input = $fh ; - } - - my $x = new $UncompressClass($input, InputLength => $comp_len) ; - ok $x, " created $UncompressClass"; - - my $len ; - my $output; - $len = $x->read($output, 100); - is $len, length($string); - is $output, $string; - - if ($type eq 'filehandle') - { - my $rest ; - $input->read($rest, 1000); - is $rest, $appended; - } - - - } - - foreach my $append (0, 1) - { - title "$UncompressClass -- Append $append" ; - - my $lex = new LexFile my $name ; - - my $string = "appended"; - my $compressed ; - my $c = new $CompressClass(\$compressed); - $c->write($string); - $c->close(); - - my $x = new $UncompressClass(\$compressed, Append => $append) ; - ok $x, " created $UncompressClass"; - - my $already = 'already'; - my $output = $already; - - my $len ; - $len = $x->read($output, 100); - is $len, length($string); - - $x->close ; - - if ($append) - { - is substr($output, 0, length($already)), $already, " got prefix"; - substr($output, 0, length($already)) = ''; - } - is $output, $string, ' Got uncompressed data' ; - } - - - foreach my $file (0, 1) - { - foreach my $trans (0, 1) - { - title "ungetc, File $file, Transparent $trans" ; - - my $lex = new LexFile my $name ; - - my $string = 'abcdeABCDE'; - my $b ; - if ($trans) - { - $b = $string ; - } - else - { - my $a = new $CompressClass(\$b) ; - $a->write($string); - $a->close ; - } - - my $from ; - if ($file) - { - writeFile($name, $b); - $from = $name ; - } - else - { - $from = \$b ; - } - - my $u = $UncompressClass->new($from, Transparent => 1) ; - my $first; - my $buff ; - - # do an ungetc before reading - $u->ungetc("X"); - $first = $u->getc(); - is $first, 'X'; - - $first = $u->getc(); - is $first, substr($string, 0,1); - $u->ungetc($first); - $first = $u->getc(); - is $first, substr($string, 0,1); - $u->ungetc($first); - - is $u->read($buff, 5), 5 ; - is $buff, substr($string, 0, 5); - - $u->ungetc($buff) ; - is $u->read($buff, length($string)), length($string) ; - is $buff, $string; - - ok $u->eof() ; - - my $extra = 'extra'; - $u->ungetc($extra); - ok ! $u->eof(); - is $u->read($buff), length($extra) ; - is $buff, $extra; - - ok $u->eof() ; - - $u->close(); - - } - } - - { - title "inflateSync on plain file"; - - my $hello = "I am a HAL 9000 computer" x 2001 ; - - my $k = new $UncompressClass(\$hello, Transparent => 1); - ok $k ; - - # Skip to the flush point -- no-op for plain file - my $status = $k->inflateSync(); - is $status, 1 - or diag $k->error() ; - - my $rest; - is $k->read($rest, length($hello)), length($hello) - or diag $k->error() ; - ok $rest eq $hello ; - - ok $k->close(); - } - - { - title "inflateSync for real"; - - # create a deflate stream with flush points - - my $hello = "I am a HAL 9000 computer" x 2001 ; - my $goodbye = "Will I dream?" x 2010; - my ($x, $err, $answer, $X, $Z, $status); - my $Answer ; - - ok ($x = new $CompressClass(\$Answer)); - ok $x ; - - is $x->write($hello), length($hello); - - # create a flush point - ok $x->flush(Z_FULL_FLUSH) ; - - is $x->write($goodbye), length($goodbye); - - ok $x->close() ; - - my $k; - $k = new $UncompressClass(\$Answer, BlockSize => 1); - ok $k ; - - my $initial; - is $k->read($initial, 1), 1 ; - is $initial, substr($hello, 0, 1); - - # Skip to the flush point - $status = $k->inflateSync(); - is $status, 1 - or diag $k->error() ; - - my $rest; - is $k->read($rest, length($hello) + length($goodbye)), - length($goodbye) - or diag $k->error() ; - ok $rest eq $goodbye ; - - ok $k->close(); - } - - { - title "inflateSync no FLUSH point"; - - # create a deflate stream with flush points - - my $hello = "I am a HAL 9000 computer" x 2001 ; - my ($x, $err, $answer, $X, $Z, $status); - my $Answer ; - - ok ($x = new $CompressClass(\$Answer)); - ok $x ; - - is $x->write($hello), length($hello); - - ok $x->close() ; - - my $k = new $UncompressClass(\$Answer, BlockSize => 1); - ok $k ; - - my $initial; - is $k->read($initial, 1), 1 ; - is $initial, substr($hello, 0, 1); - - # Skip to the flush point - $status = $k->inflateSync(); - is $status, 0 - or diag $k->error() ; - - ok $k->close(); - is $k->inflateSync(), 0 ; - } - - { - title "write tests - invalid data" ; - - #my $lex = new LexFile my $name1 ; - my $Answer ; - - #ok ! -e $name1, " File $name1 does not exist"; - - my @data = ( - [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], - [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], - [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], - [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ], - [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ], - [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ], - #[ "not readable", 'xx' ], - # same filehandle twice, 'xx' - ) ; - - foreach my $data (@data) - { - my ($send, $get) = @$data ; - title "${CompressClass}::write( $send )"; - my $copy; - eval "\$copy = $send"; - my $x = new $CompressClass(\$Answer); - ok $x, " Created $CompressClass object"; - eval { $x->write($copy) } ; - #like $@, "/^$get/", " error - $get"; - like $@, "/not a scalar reference /", " error - not a scalar reference"; - } - -# @data = ( -# [ '[ $name1 ]', "input file '$name1' does not exist" ], -# #[ "not readable", 'xx' ], -# # same filehandle twice, 'xx' -# ) ; -# -# foreach my $data (@data) -# { -# my ($send, $get) = @$data ; -# title "${CompressClass}::write( $send )"; -# my $copy; -# eval "\$copy = $send"; -# my $x = new $CompressClass(\$Answer); -# ok $x, " Created $CompressClass object"; -# ok ! $x->write($copy), " write fails" ; -# like $$Error, "/^$get/", " error - $get"; -# } - - #exit; - - } - - -# sub deepCopy -# { -# if (! ref $_[0] || ref $_[0] eq 'SCALAR') -# { -# return $_[0] ; -# } -# -# if (ref $_[0] eq 'ARRAY') -# { -# my @a ; -# for my $x ( @{ $_[0] }) -# { -# push @a, deepCopy($x); -# } -# -# return \@a ; -# } -# -# croak "bad! $_[0]"; -# -# } -# -# sub deepSubst -# { -# #my $data = shift ; -# my $from = $_[1] ; -# my $to = $_[2] ; -# -# if (! ref $_[0]) -# { -# $_[0] = $to -# if $_[0] eq $from ; -# return ; -# -# } -# -# if (ref $_[0] eq 'SCALAR') -# { -# $_[0] = \$to -# if defined ${ $_[0] } && ${ $_[0] } eq $from ; -# return ; -# -# } -# -# if (ref $_[0] eq 'ARRAY') -# { -# for my $x ( @{ $_[0] }) -# { -# deepSubst($x, $from, $to); -# } -# return ; -# } -# #croak "bad! $_[0]"; -# } - -# { -# title "More write tests" ; -# -# my $file1 = "file1" ; -# my $file2 = "file2" ; -# my $file3 = "file3" ; -# my $lex = new LexFile $file1, $file2, $file3 ; -# -# writeFile($file1, "F1"); -# writeFile($file2, "F2"); -# writeFile($file3, "F3"); -# -# my @data = ( -# [ '""', "" ], -# [ 'undef', "" ], -# [ '"abcd"', "abcd" ], -# -# [ '\""', "" ], -# [ '\undef', "" ], -# [ '\"abcd"', "abcd" ], -# -# [ '[]', "" ], -# [ '[[]]', "" ], -# [ '[[[]]]', "" ], -# [ '[\""]', "" ], -# [ '[\undef]', "" ], -# [ '[\"abcd"]', "abcd" ], -# [ '[\"ab", \"cd"]', "abcd" ], -# [ '[[\"ab"], [\"cd"]]', "abcd" ], -# -# [ '$file1', $file1 ], -# [ '$fh2', "F2" ], -# [ '[$file1, \"abc"]', "F1abc"], -# [ '[\"a", $file1, \"bc"]', "aF1bc"], -# [ '[\"a", $fh1, \"bc"]', "aF1bc"], -# [ '[\"a", $fh1, \"bc", $file2]', "aF1bcF2"], -# [ '[\"a", $fh1, \"bc", $file2, $fh3]', "aF1bcF2F3"], -# ) ; -# -# -# foreach my $data (@data) -# { -# my ($send, $get) = @$data ; -# -# my $fh1 = new IO::File "< $file1" ; -# my $fh2 = new IO::File "< $file2" ; -# my $fh3 = new IO::File "< $file3" ; -# -# title "${CompressClass}::write( $send )"; -# my $copy; -# eval "\$copy = $send"; -# my $Answer ; -# my $x = new $CompressClass(\$Answer); -# ok $x, " Created $CompressClass object"; -# my $len = length $get; -# is $x->write($copy), length($get), " write $len bytes"; -# ok $x->close(), " close ok" ; -# -# is myGZreadFile(\$Answer), $get, " got expected output" ; -# cmp_ok $$Error, '==', 0, " no error"; -# -# -# } -# -# } -} - - - - - - diff --git a/ext/Compress/Zlib/t/04generic-deflate.t b/ext/Compress/Zlib/t/04generic-deflate.t new file mode 100644 index 0000000000..2ab7e95b7b --- /dev/null +++ b/ext/Compress/Zlib/t/04generic-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +use strict; +use warnings; + +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/Compress/Zlib/t/04generic-gzip.t b/ext/Compress/Zlib/t/04generic-gzip.t new file mode 100644 index 0000000000..1e6130a7b3 --- /dev/null +++ b/ext/Compress/Zlib/t/04generic-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/04generic-rawdeflate.t b/ext/Compress/Zlib/t/04generic-rawdeflate.t new file mode 100644 index 0000000000..013c2a0d98 --- /dev/null +++ b/ext/Compress/Zlib/t/04generic-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/04generic-zip.t b/ext/Compress/Zlib/t/04generic-zip.t new file mode 100644 index 0000000000..f27e1e7942 --- /dev/null +++ b/ext/Compress/Zlib/t/04generic-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/04zlib-generic-deflate.t b/ext/Compress/Zlib/t/04zlib-generic-deflate.t new file mode 100644 index 0000000000..67f0f17ea4 --- /dev/null +++ b/ext/Compress/Zlib/t/04zlib-generic-deflate.t @@ -0,0 +1,20 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/04zlib-generic-gzip.t b/ext/Compress/Zlib/t/04zlib-generic-gzip.t new file mode 100644 index 0000000000..7a01ad9b35 --- /dev/null +++ b/ext/Compress/Zlib/t/04zlib-generic-gzip.t @@ -0,0 +1,20 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/04zlib-generic-rawdeflate.t b/ext/Compress/Zlib/t/04zlib-generic-rawdeflate.t new file mode 100644 index 0000000000..bfbd9013cf --- /dev/null +++ b/ext/Compress/Zlib/t/04zlib-generic-rawdeflate.t @@ -0,0 +1,20 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/04zlib-generic-zip.t b/ext/Compress/Zlib/t/04zlib-generic-zip.t new file mode 100644 index 0000000000..cc52209fe7 --- /dev/null +++ b/ext/Compress/Zlib/t/04zlib-generic-zip.t @@ -0,0 +1,20 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/05examples.t b/ext/Compress/Zlib/t/05examples.t index 782fc4a3df..368dab401a 100644 --- a/ext/Compress/Zlib/t/05examples.t +++ b/ext/Compress/Zlib/t/05examples.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } @@ -129,7 +129,8 @@ title "gzgrep"; check "$Perl ${examples}/gzgrep the $file1 $file2", join('', grep(/the/, @hello1, @hello2)); -for ($file1, $file2) { 1 while unlink $_ } ; +for ($file1, $file2, $stderr) { 1 while unlink $_ } ; + # filtdef/filtinf diff --git a/ext/Compress/Zlib/t/06gzsetp.t b/ext/Compress/Zlib/t/06gzsetp.t index eaba1f4f8e..41bb5c28dd 100644 --- a/ext/Compress/Zlib/t/06gzsetp.t +++ b/ext/Compress/Zlib/t/06gzsetp.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } @@ -56,7 +56,7 @@ is Compress::Zlib::zlib_version, ZLIB_VERSION, my ($input, $err, $answer, $X, $status, $Answer); - my $lex = new LexFile my $name; + my $lex = new LexFile my $name ; ok my $x = gzopen($name, "wb"); $input .= $hello; diff --git a/ext/Compress/Zlib/t/07bufsize.t b/ext/Compress/Zlib/t/07bufsize.t index 0c9b8fc030..4aab655247 100644 --- a/ext/Compress/Zlib/t/07bufsize.t +++ b/ext/Compress/Zlib/t/07bufsize.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } diff --git a/ext/Compress/Zlib/t/08encoding.t b/ext/Compress/Zlib/t/08encoding.t index 4e32d647db..56e37195f4 100644 --- a/ext/Compress/Zlib/t/08encoding.t +++ b/ext/Compress/Zlib/t/08encoding.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } @@ -114,7 +114,6 @@ if(0) ok ! $fil->gzclose, "gzclose ok" ; is $s, Encode::decode_utf8($uncomp), " decode_utf8 ok" ; - } # Add tests that check that the module traps use of wide chars diff --git a/ext/Compress/Zlib/t/09gziphdr.t b/ext/Compress/Zlib/t/09gziphdr.t index fc74060771..54157f7b25 100644 --- a/ext/Compress/Zlib/t/09gziphdr.t +++ b/ext/Compress/Zlib/t/09gziphdr.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } @@ -20,7 +20,7 @@ BEGIN { if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - plan tests => 920 + $extra ; + plan tests => 942 + $extra ; use_ok('Compress::Zlib', 2) ; use_ok('Compress::Gzip::Constants') ; @@ -249,7 +249,7 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") for my $code ( -1, undef, '', 'fred' ) { - my $code_name = defined $code ? "'$code'" : 'undef'; + 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"; @@ -257,8 +257,10 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") for my $code ( qw( 256 ) ) { - ok ! new IO::Compress::Gzip($name, OS_Code => $code) ; - like $GzipError, "/^OS_Code must be between 0 and 255, got '$code'/", + 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"; } @@ -327,7 +329,7 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") my $extra = $hdr->{ExtraField} ; if ($order) { - eq_array $extra, $result + eq_array $extra, $result; } else { eq_set $extra, $result; } @@ -363,9 +365,11 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") foreach my $test (@tests) { my ($input, $string) = @$test ; my $buffer ; - my $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input; + my $x ; + eval { $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input; }; + like $@, mkErr("$prefix$string"); + like $GzipError, "/$prefix$string/"; ok ! $x ; - like $GzipError, "/^$prefix$string/"; } @@ -414,10 +418,13 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") #hexDump(\$input); my $buffer ; - my $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input, Strict => 1; + 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"; + like $GzipError, "/$gzip_error/", " $name"; foreach my $check (0, 1) { @@ -429,6 +436,7 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") is anyUncompress(\$buffer), $string ; $x = new IO::Uncompress::Gunzip \$buffer, Strict => 0, + Transparent => 0, ParseExtra => $check; if ($check) { ok ! $x ; @@ -587,8 +595,8 @@ EOM { title "Header Corruption - ExtraField too big"; my $x; - ok ! new IO::Compress::Gzip(\$x, - -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ; + 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/'; } @@ -596,8 +604,8 @@ EOM title "Header Corruption - Create Name with Illegal Chars"; my $x; - ok ! new IO::Compress::Gzip \$x, - -Name => "fred\x02" ; + 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, @@ -606,6 +614,7 @@ EOM 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/'; @@ -621,12 +630,12 @@ EOM { title "Header Corruption - Null Chars in Name"; my $x; - ok ! new IO::Compress::Gzip \$x, - -Name => "\x00" ; + eval { new IO::Compress::Gzip \$x, -Name => "\x00" }; + like $@, mkErr('Null Character found in Name'); like $GzipError, '/Null Character found in Name/'; - ok ! new IO::Compress::Gzip \$x, - -Name => "abc\x00" ; + 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, @@ -646,8 +655,8 @@ EOM title "Header Corruption - Create Comment with Illegal Chars"; my $x; - ok ! new IO::Compress::Gzip \$x, - -Comment => "fred\x02" ; + 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, @@ -655,7 +664,8 @@ EOM -Comment => "fred\x02" ; ok $gz->close(); - ok ! new IO::Uncompress::Gunzip \$x, Strict => 1; + 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; @@ -669,12 +679,12 @@ EOM { title "Header Corruption - Null Char in Comment"; my $x; - ok ! new IO::Compress::Gzip \$x, - -Comment => "\x00" ; + eval { new IO::Compress::Gzip \$x, -Comment => "\x00" }; + like $@, mkErr('Null Character found in Comment'); like $GzipError, '/Null Character found in Comment/'; - ok ! new IO::Compress::Gzip \$x, - -Comment => "abc\x00" ; + 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, @@ -842,7 +852,7 @@ EOM ok $gunz->read($uncomp) > 0 ; ok ! $GunzipError ; my $expected = substr($buffer, - $got); - is ${ $gunz->trailingData() }, $expected_trailing; + is $gunz->trailingData(), $expected_trailing; } ok $gunz->eof() ; ok $uncomp eq $string; @@ -875,7 +885,7 @@ EOM ok ! $GunzipError ; #is $gunz->trailingData(), substr($buffer, - $got) ; } - ok ! ${ $gunz->trailingData() } ; + ok ! $gunz->trailingData() ; ok $gunz->eof() ; ok $uncomp eq $string; ok $gunz->close ; @@ -905,7 +915,7 @@ EOM ok $gunz->read($uncomp) > 0 ; ok ! $GunzipError ; } - ok ! ${ $gunz->trailingData() } ; + ok ! $gunz->trailingData() ; ok $gunz->eof() ; ok $uncomp eq $string; ok $gunz->close ; diff --git a/ext/Compress/Zlib/t/10defhdr.t b/ext/Compress/Zlib/t/10defhdr.t index f12b0d578d..55e9ceaee8 100644 --- a/ext/Compress/Zlib/t/10defhdr.t +++ b/ext/Compress/Zlib/t/10defhdr.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } @@ -325,7 +325,7 @@ EOM like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/', "Trailer Error: CRC mismatch"; ok $gunz->eof() ; - ok ! ${ $gunz->trailingData() } ; + ok ! $gunz->trailingData() ; ok $uncomp eq $string; ok $gunz->close ; } @@ -341,7 +341,7 @@ EOM my $uncomp ; ok $gunz->read($uncomp) >= 0 ; ok $gunz->eof() ; - ok ! ${ $gunz->trailingData() } ; + ok ! $gunz->trailingData() ; ok $uncomp eq $string; ok $gunz->close ; } diff --git a/ext/Compress/Zlib/t/11truncate.t b/ext/Compress/Zlib/t/11truncate.t index d0acbd88fb..1655a88456 100644 --- a/ext/Compress/Zlib/t/11truncate.t +++ b/ext/Compress/Zlib/t/11truncate.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } @@ -10,6 +10,8 @@ use strict; use warnings; use bytes; +# TODO -- split out & add zip/bzip2 + use Test::More ; use ZlibTestUtils; @@ -261,8 +263,8 @@ foreach my $CompressClass ( 'IO::Compress::RawDeflate') ok $gz; ok ! $gz->error() ; my $buff = ''; - ok $gz->read($buff) == length $part ; - ok $buff eq $part ; + is $gz->read($buff), length $part ; + is $buff, $part ; ok $gz->eof() ; $gz->close(); } diff --git a/ext/Compress/Zlib/t/12any-deflate.t b/ext/Compress/Zlib/t/12any-deflate.t new file mode 100644 index 0000000000..a97e96d630 --- /dev/null +++ b/ext/Compress/Zlib/t/12any-deflate.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/12any-gzip.t b/ext/Compress/Zlib/t/12any-gzip.t new file mode 100644 index 0000000000..0463366e15 --- /dev/null +++ b/ext/Compress/Zlib/t/12any-gzip.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/12any-rawdeflate.t b/ext/Compress/Zlib/t/12any-rawdeflate.t new file mode 100644 index 0000000000..e7425fe437 --- /dev/null +++ b/ext/Compress/Zlib/t/12any-rawdeflate.t @@ -0,0 +1,28 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/12any-transparent.t b/ext/Compress/Zlib/t/12any-transparent.t new file mode 100644 index 0000000000..c76cadbce6 --- /dev/null +++ b/ext/Compress/Zlib/t/12any-transparent.t @@ -0,0 +1,72 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; + +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +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/Compress/Zlib/t/12any-zip.t b/ext/Compress/Zlib/t/12any-zip.t new file mode 100644 index 0000000000..ffbec823c5 --- /dev/null +++ b/ext/Compress/Zlib/t/12any-zip.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/12any.t b/ext/Compress/Zlib/t/12any.t deleted file mode 100644 index 2dc8c11741..0000000000 --- a/ext/Compress/Zlib/t/12any.t +++ /dev/null @@ -1,93 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib"); - } -} - -use lib 't'; - -use strict; -use warnings; -use bytes; - -use Test::More ; -use ZlibTestUtils; - -BEGIN { - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 63 + $extra ; - - use_ok('Compress::Zlib', 2) ; - - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - - use_ok('IO::Compress::Deflate', qw($DeflateError)) ; - use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; - - use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; - use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; - use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ; -} - -foreach my $Class ( map { "IO::Compress::$_" } qw( Gzip Deflate RawDeflate) ) -{ - - for my $trans ( 0, 1 ) - { - title "AnyInflate(Transparent => $trans) with $Class" ; - my $string = <<EOM; -some text -EOM - - my $buffer ; - my $x = new $Class(\$buffer) ; - ok $x, " create $Class object" ; - ok $x->write($string), " write to object" ; - ok $x->close, " close ok" ; - - my $unc = new IO::Uncompress::AnyInflate \$buffer, Transparent => $trans ; - - ok $unc, " Created AnyInflate object" ; - my $uncomp ; - ok $unc->read($uncomp) > 0 - or print "# $IO::Uncompress::AnyInflate::AnyInflateError\n"; - ok $unc->eof(), " at eof" ; - #ok $unc->type eq $Type; - - is $uncomp, $string, " expected output" ; - } - -} - -{ - title "AnyInflate with Non-compressed data" ; - - my $string = <<EOM; -This is not compressed data -EOM - - my $buffer = $string ; - - my $unc ; - my $keep = $buffer ; - $unc = new IO::Uncompress::AnyInflate \$buffer, -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 ; -} diff --git a/ext/Compress/Zlib/t/13prime-deflate.t b/ext/Compress/Zlib/t/13prime-deflate.t new file mode 100644 index 0000000000..ac09861495 --- /dev/null +++ b/ext/Compress/Zlib/t/13prime-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/13prime-gzip.t b/ext/Compress/Zlib/t/13prime-gzip.t new file mode 100644 index 0000000000..503da50d1c --- /dev/null +++ b/ext/Compress/Zlib/t/13prime-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/13prime-rawdeflate.t b/ext/Compress/Zlib/t/13prime-rawdeflate.t new file mode 100644 index 0000000000..7e4db2eff2 --- /dev/null +++ b/ext/Compress/Zlib/t/13prime-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/13prime-zip.t b/ext/Compress/Zlib/t/13prime-zip.t new file mode 100644 index 0000000000..8402175339 --- /dev/null +++ b/ext/Compress/Zlib/t/13prime-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/13prime.t b/ext/Compress/Zlib/t/13prime.t deleted file mode 100644 index 04116e23dd..0000000000 --- a/ext/Compress/Zlib/t/13prime.t +++ /dev/null @@ -1,139 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib"); - } -} - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use ZlibTestUtils; - -BEGIN { - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 10612 + $extra ; - - - use_ok('Compress::Zlib', 2) ; - - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - - use_ok('IO::Compress::Deflate', qw($DeflateError)) ; - use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; - - use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; - use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; -} - - -my $hello = <<EOM ; -hello world -this is a test -some more stuff on this line -ad finally... -EOM - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - my $UncompressClass = getInverse($CompressClass); - - - print "#\n# Testing $UncompressClass\n#\n"; - - my $compressed ; - my $cc ; - my $gz ; - my $hsize ; - if ($CompressClass eq 'IO::Compress::Gzip') { - ok( my $x = new IO::Compress::Gzip \$compressed, - -Name => "My name", - -Comment => "this is a comment", - -ExtraField => [ 'ab' => "extra"], - -HeaderCRC => 1); - ok $x->write($hello) ; - ok $x->close ; - $cc = $compressed ; - - #hexDump($compressed) ; - - ok($gz = new IO::Uncompress::Gunzip \$cc, - #-Strict => 1, - -Transparent => 0) - or print "$GunzipError\n"; - my $un; - ok $gz->read($un) > 0 ; - ok $gz->close(); - ok $un eq $hello ; - } - else { - ok( my $x = new $CompressClass(\$compressed)); - ok $x->write($hello) ; - ok $x->close ; - $cc = $compressed ; - - ok($gz = new $UncompressClass(\$cc, - -Transparent => 0)) - or print "$GunzipError\n"; - my $un; - ok $gz->read($un) > 0 ; - ok $gz->close(); - ok $un eq $hello ; - } - - for my $blocksize (1,2,13) - { - for my $i (0 .. length($compressed) - 1) - { - for my $useBuf (0 .. 1) - { - print "#\n# BlockSize $blocksize, Length $i, Buffer $useBuf\n#\n" ; - my $lex = new LexFile my $name ; - - my $prime = substr($compressed, 0, $i); - my $rest = substr($compressed, $i); - - my $start ; - if ($useBuf) { - $start = \$rest ; - } - else { - $start = $name ; - writeFile($name, $rest); - } - - #my $gz = new $UncompressClass $name, - my $gz = new $UncompressClass $start, - -Append => 1, - -BlockSize => $blocksize, - -Prime => $prime, - -Transparent => 0 - ; - ok $gz; - ok ! $gz->error() ; - my $un ; - my $status = 1 ; - $status = $gz->read($un) while $status > 0 ; - ok $status == 0 - or print "status $status\n" ; - ok ! $gz->error() - or print "Error is '" . $gz->error() . "'\n"; - ok $un eq $hello - or print "# got [$un]\n"; - ok $gz->eof() ; - ok $gz->close() ; - } - } - } -} diff --git a/ext/Compress/Zlib/t/14gzopen.t b/ext/Compress/Zlib/t/14gzopen.t index 141b7014f7..5a90b39c23 100644 --- a/ext/Compress/Zlib/t/14gzopen.t +++ b/ext/Compress/Zlib/t/14gzopen.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } @@ -314,10 +314,7 @@ ok ! $fil->gzclose ; ok ! $fil->gzclose ; ok $fil->gzeof() ; - is $uncomp, $hello, "got expected output" ; - - } diff --git a/ext/Compress/Zlib/t/15multi-deflate.t b/ext/Compress/Zlib/t/15multi-deflate.t new file mode 100644 index 0000000000..0234a0f5cb --- /dev/null +++ b/ext/Compress/Zlib/t/15multi-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/15multi-gzip.t b/ext/Compress/Zlib/t/15multi-gzip.t new file mode 100644 index 0000000000..6cbf039a11 --- /dev/null +++ b/ext/Compress/Zlib/t/15multi-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/15multi-rawdeflate.t b/ext/Compress/Zlib/t/15multi-rawdeflate.t new file mode 100644 index 0000000000..88ae315337 --- /dev/null +++ b/ext/Compress/Zlib/t/15multi-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/15multi-zip.t b/ext/Compress/Zlib/t/15multi-zip.t new file mode 100644 index 0000000000..346f09586b --- /dev/null +++ b/ext/Compress/Zlib/t/15multi-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/15multi.t b/ext/Compress/Zlib/t/15multi.t deleted file mode 100644 index 0b65ef6371..0000000000 --- a/ext/Compress/Zlib/t/15multi.t +++ /dev/null @@ -1,149 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib"); - } -} - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use ZlibTestUtils; - -BEGIN { - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 575 + $extra ; - - use_ok('Compress::Zlib', 2) ; - - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ; - use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; - use_ok('IO::Compress::Deflate', qw($DeflateError)) ; - use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; - use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; -} - - -my @buffers ; -push @buffers, <<EOM ; -hello world -this is a test -some more stuff on this line -ad finally... -EOM - -push @buffers, <<EOM ; -some more stuff -EOM - -push @buffers, <<EOM ; -even more stuff -EOM - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - my $UncompressClass = getInverse($CompressClass); - - - my $cc ; - my $gz ; - my $hsize ; - my %headers = () ; - - - foreach my $fb ( qw( file filehandle buffer ) ) - { - - foreach my $i (1 .. @buffers) { - - title "Testing $CompressClass with $i streams to $fb"; - - my @buffs = @buffers[0..$i -1] ; - - if ($CompressClass eq 'IO::Compress::Gzip') { - %headers = ( - Strict => 0, - Comment => "this is a comment", - ExtraField => "some extra", - HeaderCRC => 1); - - } - - my $lex = new LexFile my $name ; - my $output ; - if ($fb eq 'buffer') - { - my $compressed = ''; - $output = \$compressed; - } - elsif ($fb eq 'filehandle') - { - $output = new IO::File ">$name" ; - } - else - { - $output = $name ; - } - - my $x = new $CompressClass($output, AutoClose => 1, %headers); - isa_ok $x, $CompressClass, ' $x' ; - - foreach my $buffer (@buffs) { - ok $x->write($buffer), " Write OK" ; - # this will add an extra "empty" stream - ok $x->newStream(), " newStream OK" ; - } - ok $x->close, " Close ok" ; - - #hexDump($compressed) ; - - foreach my $unc ($UncompressClass, 'IO::Uncompress::AnyInflate') { - title " Testing $CompressClass with $unc and $i streams, from $fb"; - $cc = $output ; - if ($fb eq 'filehandle') - { - $cc = new IO::File "<$name" ; - } - my $gz = new $unc($cc, - Strict => 0, - AutoClose => 1, - Append => 1, - MultiStream => 1, - Transparent => 0); - isa_ok $gz, $unc, ' $gz' ; - - my $un = ''; - 1 while $gz->read($un) > 0 ; - #print "[[$un]]\n" while $gz->read($un) > 0 ; - ok ! $gz->error(), " ! error()" - or diag "Error is " . $gz->error() ; - ok $gz->eof(), " eof()"; - ok $gz->close(), " close() ok" - or diag "errno $!\n" ; - - is $gz->streamCount(), $i +1, " streamCount ok" - or diag "Stream count is " . $gz->streamCount(); - ok $un eq join('', @buffs), " expected output" ; - - } - } - } -} - - -# corrupt one of the streams - all previous should be ok -# trailing stuff -# need a way to skip to the start of the next stream. -# check that "tell" works ok diff --git a/ext/Compress/Zlib/t/16oneshot-deflate.t b/ext/Compress/Zlib/t/16oneshot-deflate.t new file mode 100644 index 0000000000..8bee7b545b --- /dev/null +++ b/ext/Compress/Zlib/t/16oneshot-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/16oneshot-gzip-only.t b/ext/Compress/Zlib/t/16oneshot-gzip-only.t new file mode 100644 index 0000000000..d5c7b80f00 --- /dev/null +++ b/ext/Compress/Zlib/t/16oneshot-gzip-only.t @@ -0,0 +1,134 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +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))[8]; + # 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))[8]; + 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/Compress/Zlib/t/16oneshot-gzip.t b/ext/Compress/Zlib/t/16oneshot-gzip.t new file mode 100644 index 0000000000..c558689c5d --- /dev/null +++ b/ext/Compress/Zlib/t/16oneshot-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/16oneshot-rawdeflate.t b/ext/Compress/Zlib/t/16oneshot-rawdeflate.t new file mode 100644 index 0000000000..63644cebc6 --- /dev/null +++ b/ext/Compress/Zlib/t/16oneshot-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/16oneshot-zip-only.t b/ext/Compress/Zlib/t/16oneshot-zip-only.t new file mode 100644 index 0000000000..38a91f4fa1 --- /dev/null +++ b/ext/Compress/Zlib/t/16oneshot-zip-only.t @@ -0,0 +1,175 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +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 => 95 + $extra ; + + use_ok('IO::Compress::Zip', qw(zip $ZipError)) ; + 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))[8]; + # 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))[8]; + 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 $store (0, 8) + { + title "Stream $stream, Store $store"; + + my $lex = new LexFile my $file1; + + my $content = "hello "; + writeFile($file1, $content); + + ok zip(\$content => $file1 , Store => !$store, Stream => $stream), " zip ok" + or diag $ZipError ; + + my $got ; + if ($stream && ! $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}, $store, " MethodID is $store" ; + } +} + +# TODO add more error cases + diff --git a/ext/Compress/Zlib/t/16oneshot-zip.t b/ext/Compress/Zlib/t/16oneshot-zip.t new file mode 100644 index 0000000000..a86eb7cbd1 --- /dev/null +++ b/ext/Compress/Zlib/t/16oneshot-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/16oneshot.t b/ext/Compress/Zlib/t/16oneshot.t deleted file mode 100644 index d382ba00a2..0000000000 --- a/ext/Compress/Zlib/t/16oneshot.t +++ /dev/null @@ -1,1504 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib"); - } -} - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use ZlibTestUtils; - -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 => 2462 + $extra ; - - use_ok('Compress::Zlib', 2) ; - - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - - use_ok('IO::Compress::Deflate', qw($DeflateError)) ; - use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; - - use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; - use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; - - use_ok('IO::Uncompress::AnyInflate', qw(anyinflate $AnyInflateError)) ; - -} - - -# Check zlib_version and ZLIB_VERSION are the same. -is Compress::Zlib::zlib_version, ZLIB_VERSION, - "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; - - - -foreach my $bit ('IO::Compress::Gzip', - 'IO::Uncompress::Gunzip', - 'IO::Compress::Deflate', - 'IO::Uncompress::Inflate', - 'IO::Compress::RawDeflate', - 'IO::Uncompress::RawInflate', - 'IO::Uncompress::AnyInflate', - ) -{ - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - title "Testing $TopType Error Cases"; - - my $a; - my $x ; - - eval { $a = $Func->(\$a => \$x, Fred => 1) ;} ; - like $@, mkErr("^$TopType: unknown key value\\(s\\) Fred"), ' Illegal Parameters'; - - eval { $a = $Func->() ;} ; - like $@, mkErr("^$TopType: expected at least 1 parameters"), ' No Parameters'; - - eval { $a = $Func->(\$x, \1) ;} ; - like $@, mkErr("^$TopType: output buffer is read-only"), ' Output is read-only' ; - - my $in ; - eval { $a = $Func->($in, \$x) ;} ; - like $@, mkErr("^$TopType: input filename is undef or null string"), - ' Input filename undef' ; - - $in = ''; - eval { $a = $Func->($in, \$x) ;} ; - like $@, mkErr("^$TopType: input filename is undef or null string"), - ' Input filename empty' ; - - my $lex1 = new LexFile my $in1 ; - writeFile($in1, "abc"); - my $out = $in1 ; - eval { $a = $Func->($in1, $out) ;} ; - like $@, mkErr("^$TopType: input and output filename are identical"), - ' Input and Output filename are the same'; - - eval { $a = $Func->(\$in, \$in) ;} ; - like $@, mkErr("^$TopType: input and output buffer are identical"), - ' Input and Output buffer are the same'; - - my $lex = new LexFile my $out_file ; - open OUT, ">$out_file" ; - eval { $a = $Func->(\*OUT, \*OUT) ;} ; - like $@, mkErr("^$TopType: input and output handle are identical"), - ' Input and Output handle are the same'; - - close OUT; - is -s $out_file, 0, " File zero length" ; - { - my %x = () ; - my $object = bless \%x, "someClass" ; - - # Buffer not a scalar reference - #eval { $a = $Func->(\$x, \%x) ;} ; - eval { $a = $Func->(\$x, $object) ;} ; - like $@, mkErr("^$TopType: illegal output parameter"), - ' Bad Output Param'; - - - #eval { $a = $Func->(\%x, \$x) ;} ; - eval { $a = $Func->($object, \$x) ;} ; - like $@, mkErr("^$TopType: illegal input parameter"), - ' Bad Input Param'; - } - - my $filename = 'abc.def'; - ok ! -e $filename, " input file '$filename' does not exist"; - $a = $Func->($filename, \$x) ; - is $a, undef, " $TopType returned undef"; - like $$Error, "/^input file '$filename' does not exist\$/", " input File '$filename' does not exist"; - - $filename = '/tmp/abd/abc.def'; - ok ! -e $filename, " output File '$filename' does not exist"; - $a = $Func->(\$x, $filename) ; - is $a, undef, " $TopType returned undef"; - like $$Error, ("/^(cannot open file '$filename'|input file '$filename' does not exist):/"), " output File '$filename' does not exist"; - - $a = $Func->(\$x, '<abc>') ; - is $a, undef, " $TopType returned undef"; - like $$Error, "/Need input fileglob for outout fileglob/", - ' Output fileglob with no input fileglob'; - - $a = $Func->('<abc)>', '<abc>') ; - is $a, undef, " $TopType returned undef"; - like $$Error, "/Unmatched \\) in input fileglob/", - " Unmatched ) in input fileglob"; -} - -foreach my $bit ('IO::Uncompress::Gunzip', - 'IO::Uncompress::Inflate', - 'IO::Uncompress::RawInflate', - 'IO::Uncompress::AnyInflate', - ) -{ - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $data = "mary had a little lamb" ; - my $keep = $data ; - - for my $trans ( 0, 1) - { - title "Non-compressed data with $TopType, Transparent => $trans "; - my $a; - my $x ; - my $out = '' ; - - $a = $Func->(\$data, \$out, Transparent => $trans) ; - - is $data, $keep, " Input buffer not changed" ; - - if ($trans) - { - ok $a, " $TopType returned true" ; - is $out, $data, " got expected output" ; - ok ! $$Error, " no error [$$Error]" ; - } - else - { - ok ! $a, " $TopType returned false" ; - #like $$Error, '/xxx/', " error" ; - ok $$Error, " error is '$$Error'" ; - } - } -} - -foreach my $bit ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - my $TopTypeInverse = getInverse($bit); - my $FuncInverse = getTopFuncRef($TopTypeInverse); - my $ErrorInverse = getErrorRef($TopTypeInverse); - - title "$TopTypeInverse - corrupt data"; - - my $data = "abcd" x 100 ; - my $out; - - ok $Func->(\$data, \$out), " $TopType ok"; - - # corrupt the compressed data - #substr($out, -10, 10) = "x" x 10 ; - substr($out, int(length($out)/3), 10) = 'abcdeabcde'; - - my $result; - ok ! $FuncInverse->(\$out => \$result, Transparent => 0), " $TopTypeInverse ok"; - ok $$ErrorInverse, " Got error '$$ErrorInverse'" ; - - #is $result, $data, " data ok"; - - ok ! anyinflate(\$out => \$result, Transparent => 0), " anyinflate ok"; - ok $AnyInflateError, " Got error '$AnyInflateError'" ; -} - - -foreach my $bit ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - my $TopTypeInverse = getInverse($bit); - my $FuncInverse = getTopFuncRef($TopTypeInverse); - - for my $append ( 1, 0 ) - { - my $already = ''; - $already = 'abcde' if $append ; - - for my $buffer ( undef, '', "abcde" ) - { - - my $disp_content = defined $buffer ? $buffer : '<undef>' ; - - my $keep = $buffer; - my $out_file = "abcde.out"; - my $in_file = "abcde.in"; - - { - title "$TopType - From Buff to Buff content '$disp_content' Append $append" ; - - my $output = $already; - ok &$Func(\$buffer, \$output, Append => $append), ' Compressed ok' ; - - is $keep, $buffer, " Input buffer not changed" ; - my $got = anyUncompress(\$output, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - - } - - { - title "$TopType - From Buff to Array Ref content '$disp_content' Append $append" ; - - my @output = ('first') ; - ok &$Func(\$buffer, \@output, Append => $append), ' Compressed ok' ; - - is $output[0], 'first', " Array[0] unchanged"; - is $keep, $buffer, " Input buffer not changed" ; - my $got = anyUncompress($output[1]); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - } - - { - title "$TopType - From Array Ref to Array Ref content '$disp_content' Append $append" ; - - my @output = ('first') ; - my @input = ( \$buffer); - ok &$Func(\@input, \@output, Append => $append), ' Compressed ok' ; - - is $output[0], 'first', " Array[0] unchanged"; - is $keep, $buffer, " Input buffer not changed" ; - my $got = anyUncompress($output[1]); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - - } - - { - title "$TopType - From Buff to Filename content '$disp_content' Append $append" ; - - my $lex = new LexFile($out_file) ; - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - - ok &$Func(\$buffer, $out_file, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - } - - { - title "$TopType - From Buff to Handle content '$disp_content' Append $append" ; - - my $lex = new LexFile($out_file) ; - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - my $of = new IO::File ">>$out_file" ; - ok $of, " Created output filehandle" ; - - ok &$Func(\$buffer, $of, AutoClose => 1, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - } - - - { - title "$TopType - From Filename to Filename content '$disp_content' Append $append" ; - - my $lex = new LexFile($in_file, $out_file) ; - writeFile($in_file, $buffer); - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - - ok &$Func($in_file => $out_file, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - - } - - { - title "$TopType - From Filename to Handle content '$disp_content' Append $append" ; - - my $lex = new LexFile($in_file, $out_file) ; - writeFile($in_file, $buffer); - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - my $out = new IO::File ">>$out_file" ; - - ok &$Func($in_file, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - - } - - { - title "$TopType - From Filename to Buffer content '$disp_content' Append $append" ; - - my $lex = new LexFile($in_file, $out_file) ; - writeFile($in_file, $buffer); - - my $out = $already; - - ok &$Func($in_file => \$out, Append => $append), ' Compressed ok' ; - - my $got = anyUncompress(\$out, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - - } - - { - title "$TopType - From Handle to Filename content '$disp_content' Append $append" ; - - my $lex = new LexFile($in_file, $out_file) ; - writeFile($in_file, $buffer); - my $in = new IO::File "<$in_file" ; - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - - ok &$Func($in, $out_file, Append => $append), ' Compressed ok' - or diag "error is $GzipError" ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $buffer, $got, " Uncompressed matches original"; - - } - - { - title "$TopType - From Handle to Handle content '$disp_content' Append $append" ; - - my $lex = new LexFile($in_file, $out_file) ; - writeFile($in_file, $buffer); - my $in = new IO::File "<$in_file" ; - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - my $out = new IO::File ">>$out_file" ; - - ok &$Func($in, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $buffer, $got, " Uncompressed matches original"; - - } - - { - title "$TopType - From Handle to Buffer content '$disp_content' Append $append" ; - - my $lex = new LexFile($in_file, $out_file) ; - writeFile($in_file, $buffer); - my $in = new IO::File "<$in_file" ; - - my $out = $already ; - - ok &$Func($in, \$out, Append => $append), ' Compressed ok' ; - - my $got = anyUncompress(\$out, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $buffer, $got, " Uncompressed matches original"; - - } - - { - title "$TopType - From stdin (via '-') to Buffer content '$disp_content' Append $append" ; - - my $lex = new LexFile($in_file, $out_file) ; - writeFile($in_file, $buffer); - - open(SAVEIN, "<&STDIN"); - my $dummy = fileno SAVEIN ; - ok open(STDIN, "<$in_file"), " redirect STDIN"; - - my $out = $already; - - ok &$Func('-', \$out, Append => $append), ' Compressed ok' - or diag $$Error ; - - open(STDIN, "<&SAVEIN"); - - my $got = anyUncompress(\$out, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $buffer, $got, " Uncompressed matches original"; - - } - - } - } -} - -foreach my $bit ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $TopTypeInverse = getInverse($bit); - my $FuncInverse = getTopFuncRef($TopTypeInverse); - - my ($file1, $file2) = ("file1", "file2"); - my $lex = new LexFile($file1, $file2) ; - - writeFile($file1, "data1"); - writeFile($file2, "data2"); - my $of = new IO::File "<$file1" ; - ok $of, " Created output filehandle" ; - - my @input = ( undef, "", $file2, \undef, \'', \"abcde", $of) ; - my @expected = ("", "", $file2, "", "", "abcde", "data1"); - my @uexpected = ("", "", "data2", "", "", "abcde", "data1"); - - my @keep = @input ; - - { - title "$TopType - From Array Ref to Array Ref" ; - - my @output = ('first') ; - ok &$Func(\@input, \@output, AutoClose => 0), ' Compressed ok' ; - - is $output[0], 'first', " Array[0] unchanged"; - - is_deeply \@input, \@keep, " Input array not changed" ; - my @got = shift @output; - foreach (@output) { push @got, anyUncompress($_) } - - is_deeply \@got, ['first', @expected], " Got Expected uncompressed data"; - - } - - { - title "$TopType - From Array Ref to Buffer" ; - - # rewind the filehandle - $of->open("<$file1") ; - - my $output ; - ok &$Func(\@input, \$output, AutoClose => 0), ' Compressed ok' ; - - my $got = anyUncompress(\$output); - - is $got, join('', @expected), " Got Expected uncompressed data"; - } - - { - title "$TopType - From Array Ref to Filename" ; - - my ($file3) = ("file3"); - my $lex = new LexFile($file3) ; - - # rewind the filehandle - $of->open("<$file1") ; - - my $output ; - ok &$Func(\@input, $file3, AutoClose => 0), ' Compressed ok' ; - - my $got = anyUncompress($file3); - - is $got, join('', @expected), " Got Expected uncompressed data"; - } - - { - title "$TopType - From Array Ref to Filehandle" ; - - my ($file3) = ("file3"); - my $lex = new LexFile($file3) ; - - my $fh3 = new IO::File ">$file3"; - - # rewind the filehandle - $of->open("<$file1") ; - - my $output ; - ok &$Func(\@input, $fh3, AutoClose => 0), ' Compressed ok' ; - - $fh3->close(); - - my $got = anyUncompress($file3); - - is $got, join('', @expected), " Got Expected uncompressed data"; - } -} - -foreach my $bit ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $TopTypeInverse = getInverse($bit); - my $FuncInverse = getTopFuncRef($TopTypeInverse); - - my @inFiles = map { "in$_.tmp" } 1..4; - my @outFiles = map { "out$_.tmp" } 1..4; - my $lex = new LexFile(@inFiles, @outFiles); - - writeFile($_, "data $_") foreach @inFiles ; - - { - title "$TopType - Hash Ref: to filename" ; - - my $output ; - ok &$Func( { $inFiles[0] => $outFiles[0], - $inFiles[1] => $outFiles[1], - $inFiles[2] => $outFiles[2] } ), ' Compressed ok' ; - - foreach (0 .. 2) - { - my $got = anyUncompress($outFiles[$_]); - is $got, "data $inFiles[$_]", " Uncompressed $_ matches original"; - } - } - - { - title "$TopType - Hash Ref: to buffer" ; - - my @buffer ; - ok &$Func( { $inFiles[0] => \$buffer[0], - $inFiles[1] => \$buffer[1], - $inFiles[2] => \$buffer[2] } ), ' Compressed ok' ; - - foreach (0 .. 2) - { - my $got = anyUncompress(\$buffer[$_]); - is $got, "data $inFiles[$_]", " Uncompressed $_ matches original"; - } - } - - { - title "$TopType - Hash Ref: to undef" ; - - my @buffer ; - my %hash = ( $inFiles[0] => undef, - $inFiles[1] => undef, - $inFiles[2] => undef, - ); - - ok &$Func( \%hash ), ' Compressed ok' ; - - foreach (keys %hash) - { - my $got = anyUncompress(\$hash{$_}); - is $got, "data $_", " Uncompressed $_ matches original"; - } - } - - { - title "$TopType - Filename to Hash Ref" ; - - my %output ; - ok &$Func( $inFiles[0] => \%output), ' Compressed ok' ; - - is keys %output, 1, " one pair in hash" ; - my ($k, $v) = each %output; - is $k, $inFiles[0], " key is '$inFiles[0]'"; - my $got = anyUncompress($v); - is $got, "data $inFiles[0]", " Uncompressed matches original"; - } - - { - title "$TopType - File Glob to Hash Ref" ; - - my %output ; - ok &$Func( '<in*.tmp>' => \%output), ' Compressed ok' ; - - is keys %output, 4, " four pairs in hash" ; - foreach my $fil (@inFiles) - { - ok exists $output{$fil}, " key '$fil' exists" ; - my $got = anyUncompress($output{$fil}); - is $got, "data $fil", " Uncompressed matches original"; - } - } - - -# if (0) -# { -# title "$TopType - Hash Ref to Array Ref" ; -# -# my @output = ('first') ; -# ok &$Func( { \@input, \@output } , AutoClose => 0), ' Compressed ok' ; -# -# is $output[0], 'first', " Array[0] unchanged"; -# -# is_deeply \@input, \@keep, " Input array not changed" ; -# my @got = shift @output; -# foreach (@output) { push @got, anyUncompress($_) } -# -# is_deeply \@got, ['first', @expected], " Got Expected uncompressed data"; -# -# } -# -# if (0) -# { -# title "$TopType - From Array Ref to Buffer" ; -# -# # rewind the filehandle -# $of->open("<$file1") ; -# -# my $output ; -# ok &$Func(\@input, \$output, AutoClose => 0), ' Compressed ok' ; -# -# my $got = anyUncompress(\$output); -# -# is $got, join('', @expected), " Got Expected uncompressed data"; -# } -# -# if (0) -# { -# title "$TopType - From Array Ref to Filename" ; -# -# my ($file3) = ("file3"); -# my $lex = new LexFile($file3) ; -# -# # rewind the filehandle -# $of->open("<$file1") ; -# -# my $output ; -# ok &$Func(\@input, $file3, AutoClose => 0), ' Compressed ok' ; -# -# my $got = anyUncompress($file3); -# -# is $got, join('', @expected), " Got Expected uncompressed data"; -# } -# -# if (0) -# { -# title "$TopType - From Array Ref to Filehandle" ; -# -# my ($file3) = ("file3"); -# my $lex = new LexFile($file3) ; -# -# my $fh3 = new IO::File ">$file3"; -# -# # rewind the filehandle -# $of->open("<$file1") ; -# -# my $output ; -# ok &$Func(\@input, $fh3, AutoClose => 0), ' Compressed ok' ; -# -# $fh3->close(); -# -# my $got = anyUncompress($file3); -# -# is $got, join('', @expected), " Got Expected uncompressed data"; -# } -} - -foreach my $bit ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - for my $files ( [qw(a1)], [qw(a1 a2 a3)] ) - { - - my $tmpDir1 = 'tmpdir1'; - my $tmpDir2 = 'tmpdir2'; - my $lex = new LexDir($tmpDir1, $tmpDir2) ; - - mkdir $tmpDir1, 0777; - mkdir $tmpDir2, 0777; - - ok -d $tmpDir1, " Temp Directory $tmpDir1 exists"; - #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist"; - - my @files = map { "$tmpDir1/$_.tmp" } @$files ; - foreach (@files) { writeFile($_, "abc $_") } - - my @expected = map { "abc $_" } @files ; - my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ; - - { - title "$TopType - From FileGlob to FileGlob files [@$files]" ; - - ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' Compressed ok' - or diag $$Error ; - - my @copy = @expected; - for my $file (@outFiles) - { - is anyUncompress($file), shift @copy, " got expected from $file" ; - } - - is @copy, 0, " got all files"; - } - - { - title "$TopType - From FileGlob to Array files [@$files]" ; - - my @buffer = ('first') ; - ok &$Func("<$tmpDir1/a*.tmp>" => \@buffer), ' Compressed ok' - or diag $$Error ; - - is shift @buffer, 'first'; - - my @copy = @expected; - for my $buffer (@buffer) - { - is anyUncompress($buffer), shift @copy, " got expected " ; - } - - is @copy, 0, " got all files"; - } - - { - title "$TopType - From FileGlob to Buffer files [@$files]" ; - - my $buffer ; - ok &$Func("<$tmpDir1/a*.tmp>" => \$buffer), ' Compressed ok' - or diag $$Error ; - - #hexDump(\$buffer); - - my $got = anyUncompress([ \$buffer, MultiStream => 1 ]); - - is $got, join("", @expected), " got expected" ; - } - - { - title "$TopType - From FileGlob to Filename files [@$files]" ; - - my $filename = "abcde"; - my $lex = new LexFile($filename) ; - - ok &$Func("<$tmpDir1/a*.tmp>" => $filename), ' Compressed ok' - or diag $$Error ; - - #hexDump(\$buffer); - - my $got = anyUncompress([$filename, MultiStream => 1]); - - is $got, join("", @expected), " got expected" ; - } - - { - title "$TopType - From FileGlob to Filehandle files [@$files]" ; - - my $filename = "abcde"; - my $lex = new LexFile($filename) ; - my $fh = new IO::File ">$filename"; - - ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1), ' Compressed ok' - or diag $$Error ; - - #hexDump(\$buffer); - - my $got = anyUncompress([$filename, MultiStream => 1]); - - is $got, join("", @expected), " got expected" ; - } - } - -} - -foreach my $bit ('IO::Uncompress::Gunzip', - 'IO::Uncompress::Inflate', - 'IO::Uncompress::RawInflate', - 'IO::Uncompress::AnyInflate', - ) -{ - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $buffer = "abcde" ; - my $buffer2 = "ABCDE" ; - my $keep_orig = $buffer; - - my $comp = compressBuffer($TopType, $buffer) ; - my $comp2 = compressBuffer($TopType, $buffer2) ; - my $keep_comp = $comp; - - my $incumbent = "incumbent data" ; - - for my $append (0, 1) - { - my $expected = $buffer ; - $expected = $incumbent . $buffer if $append ; - - { - title "$TopType - From Buff to Buff, Append($append)" ; - - my $output ; - $output = $incumbent if $append ; - ok &$Func(\$comp, \$output, Append => $append), ' Uncompressed ok' ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Buff to Array, Append($append)" ; - - my @output = ('first'); - #$output = $incumbent if $append ; - ok &$Func(\$comp, \@output, Append => $append), ' Uncompressed ok' ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output[0], 'first', " Uncompressed matches original"; - is ${ $output[1] }, $buffer, " Uncompressed matches original" - or diag $output[1] ; - is @output, 2, " only 2 elements in the array" ; - } - - { - title "$TopType - From Buff to Filename, Append($append)" ; - - my $out_file = "abcde"; - my $lex = new LexFile($out_file) ; - if ($append) - { writeFile($out_file, $incumbent) } - else - { ok ! -e $out_file, " Output file does not exist" } - - ok &$Func(\$comp, $out_file, Append => $append), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Buff to Handle, Append($append)" ; - - my $out_file = "abcde"; - my $lex = new LexFile($out_file) ; - my $of ; - if ($append) { - writeFile($out_file, $incumbent) ; - $of = new IO::File "+< $out_file" ; - } - else { - ok ! -e $out_file, " Output file does not exist" ; - $of = new IO::File "> $out_file" ; - } - isa_ok $of, 'IO::File', ' $of' ; - - ok &$Func(\$comp, $of, Append => $append, AutoClose => 1), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Filename to Filename, Append($append)" ; - - my $out_file = "abcde.out"; - my $in_file = "abcde.in"; - my $lex = new LexFile($in_file, $out_file) ; - if ($append) - { writeFile($out_file, $incumbent) } - else - { ok ! -e $out_file, " Output file does not exist" } - - writeFile($in_file, $comp); - - ok &$Func($in_file, $out_file, Append => $append), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Filename to Handle, Append($append)" ; - - my $out_file = "abcde.out"; - my $in_file = "abcde.in"; - my $lex = new LexFile($in_file, $out_file) ; - my $out ; - if ($append) { - writeFile($out_file, $incumbent) ; - $out = new IO::File "+< $out_file" ; - } - else { - ok ! -e $out_file, " Output file does not exist" ; - $out = new IO::File "> $out_file" ; - } - isa_ok $out, 'IO::File', ' $out' ; - - writeFile($in_file, $comp); - - ok &$Func($in_file, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Filename to Buffer, Append($append)" ; - - my $in_file = "abcde.in"; - my $lex = new LexFile($in_file) ; - writeFile($in_file, $comp); - - my $output ; - $output = $incumbent if $append ; - - ok &$Func($in_file, \$output, Append => $append), ' Uncompressed ok' ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Handle to Filename, Append($append)" ; - - my $out_file = "abcde.out"; - my $in_file = "abcde.in"; - my $lex = new LexFile($in_file, $out_file) ; - if ($append) - { writeFile($out_file, $incumbent) } - else - { ok ! -e $out_file, " Output file does not exist" } - - writeFile($in_file, $comp); - my $in = new IO::File "<$in_file" ; - - ok &$Func($in, $out_file, Append => $append), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Handle to Handle, Append($append)" ; - - my $out_file = "abcde.out"; - my $in_file = "abcde.in"; - my $lex = new LexFile($in_file, $out_file) ; - my $out ; - if ($append) { - writeFile($out_file, $incumbent) ; - $out = new IO::File "+< $out_file" ; - } - else { - ok ! -e $out_file, " Output file does not exist" ; - $out = new IO::File "> $out_file" ; - } - isa_ok $out, 'IO::File', ' $out' ; - - writeFile($in_file, $comp); - my $in = new IO::File "<$in_file" ; - - ok &$Func($in, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Filename to Buffer, Append($append)" ; - - my $in_file = "abcde.in"; - my $lex = new LexFile($in_file) ; - writeFile($in_file, $comp); - my $in = new IO::File "<$in_file" ; - - my $output ; - $output = $incumbent if $append ; - - ok &$Func($in, \$output, Append => $append), ' Uncompressed ok' ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From stdin (via '-') to Buffer content, Append($append) " ; - - my $in_file = "abcde.in"; - my $lex = new LexFile($in_file) ; - writeFile($in_file, $comp); - - open(SAVEIN, "<&STDIN"); - my $dummy = fileno SAVEIN ; - ok open(STDIN, "<$in_file"), " redirect STDIN"; - - my $output ; - $output = $incumbent if $append ; - - ok &$Func('-', \$output, Append => $append), ' Uncompressed ok' - or diag $$Error ; - - open(STDIN, "<&SAVEIN"); - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output, $expected, " Uncompressed matches original"; - } - } - - { - title "$TopType - From Handle to Buffer, InputLength" ; - - my $out_file = "abcde.out"; - my $in_file = "abcde.in"; - my $lex = new LexFile($in_file, $out_file) ; - my $out ; - - my $expected = $buffer ; - my $appended = 'appended'; - my $len_appended = length $appended; - writeFile($in_file, $comp . $appended . $comp . $appended) ; - my $in = new IO::File "<$in_file" ; - - ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ; - - is $out, $expected, " Uncompressed matches original"; - - my $buff; - is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok"; - is $buff, $appended, " Appended data ok"; - - $out = ''; - ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ; - - is $out, $expected, " Uncompressed matches original"; - - $buff = ''; - is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok"; - is $buff, $appended, " Appended data ok"; - } - - for my $stdin ('-', *STDIN) # , \*STDIN) - { - title "$TopType - From stdin (via $stdin) to Buffer content, InputLength" ; - - my $lex = new LexFile my $in_file ; - my $expected = $buffer ; - my $appended = 'appended'; - my $len_appended = length $appended; - writeFile($in_file, $comp . $appended ) ; - - open(SAVEIN, "<&STDIN"); - my $dummy = fileno SAVEIN ; - ok open(STDIN, "<$in_file"), " redirect STDIN"; - - my $output ; - - ok &$Func($stdin, \$output, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' - or diag $$Error ; - - my $buff ; - is read(STDIN, $buff, $len_appended), $len_appended, " Length of Appended data ok"; - - is $output, $expected, " Uncompressed matches original"; - is $buff, $appended, " Appended data ok"; - - open(STDIN, "<&SAVEIN"); - } -} - -foreach my $bit ('IO::Uncompress::Gunzip', - 'IO::Uncompress::Inflate', - 'IO::Uncompress::RawInflate', - 'IO::Uncompress::AnyInflate', - ) -{ - # TODO -- Add Append mode tests - - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $buffer = "abcde" ; - my $keep_orig = $buffer; - - - my $null = compressBuffer($TopType, "") ; - my $undef = compressBuffer($TopType, undef) ; - my $comp = compressBuffer($TopType, $buffer) ; - my $keep_comp = $comp; - - my $incumbent = "incumbent data" ; - - #my ($file1, $file2) = ("file1", "file2"); - my $lex = new LexFile(my $file1, my $file2) ; - - writeFile($file1, compressBuffer($TopType,"data1")); - writeFile($file2, compressBuffer($TopType,"data2")); - - my $of = new IO::File "<$file1" ; - ok $of, " Created output filehandle" ; - - my @input = ($file2, \$undef, \$null, \$comp, $of) ; - my @expected = ('data2', '', '', 'abcde', 'data1'); - - my @keep = @input ; - - { - title "$TopType - From ArrayRef to Buffer" ; - - my $output ; - ok &$Func(\@input, \$output, AutoClose => 0), ' UnCompressed ok' ; - - is $output, join('', @expected) - } - - { - title "$TopType - From ArrayRef to Filename" ; - - my $output = 'abc'; - my $lex = new LexFile $output; - $of->open("<$file1") ; - - ok &$Func(\@input, $output, AutoClose => 0), ' UnCompressed ok' ; - - is readFile($output), join('', @expected) - } - - { - title "$TopType - From ArrayRef to Filehandle" ; - - my $output = 'abc'; - my $lex = new LexFile $output; - my $fh = new IO::File ">$output" ; - $of->open("<$file1") ; - - ok &$Func(\@input, $fh, AutoClose => 0), ' UnCompressed ok' ; - $fh->close; - - is readFile($output), join('', @expected) - } - - { - title "$TopType - From Array Ref to Array Ref" ; - - my @output = (\'first') ; - $of->open("<$file1") ; - ok &$Func(\@input, \@output, AutoClose => 0), ' UnCompressed ok' ; - - is_deeply \@input, \@keep, " Input array not changed" ; - is_deeply [map { defined $$_ ? $$_ : "" } @output], - ['first', @expected], - " Got Expected uncompressed data"; - - } -} - -foreach my $bit ('IO::Uncompress::Gunzip', - 'IO::Uncompress::Inflate', - 'IO::Uncompress::RawInflate', - 'IO::Uncompress::AnyInflate', - ) -{ - # TODO -- Add Append mode tests - - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $tmpDir1 = 'tmpdir1'; - my $tmpDir2 = 'tmpdir2'; - my $lex = new LexDir($tmpDir1, $tmpDir2) ; - - mkdir $tmpDir1, 0777; - mkdir $tmpDir2, 0777; - - ok -d $tmpDir1, " Temp Directory $tmpDir1 exists"; - #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist"; - - my @files = map { "$tmpDir1/$_.tmp" } qw( a1 a2 a3) ; - foreach (@files) { writeFile($_, compressBuffer($TopType, "abc $_")) } - - my @expected = map { "abc $_" } @files ; - my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ; - - { - title "$TopType - From FileGlob to FileGlob" ; - - ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' UnCompressed ok' - or diag $$Error ; - - my @copy = @expected; - for my $file (@outFiles) - { - is readFile($file), shift @copy, " got expected from $file" ; - } - - is @copy, 0, " got all files"; - } - - { - title "$TopType - From FileGlob to Arrayref" ; - - my @output = (\'first'); - ok &$Func("<$tmpDir1/a*.tmp>" => \@output), ' UnCompressed ok' - or diag $$Error ; - - my @copy = ('first', @expected); - for my $data (@output) - { - is $$data, shift @copy, " got expected data" ; - } - - is @copy, 0, " got all files"; - } - - { - title "$TopType - From FileGlob to Buffer" ; - - my $output ; - ok &$Func("<$tmpDir1/a*.tmp>" => \$output), ' UnCompressed ok' - or diag $$Error ; - - is $output, join('', @expected), " got expected uncompressed data"; - } - - { - title "$TopType - From FileGlob to Filename" ; - - my $output = 'abc' ; - my $lex = new LexFile $output ; - ok ! -e $output, " $output does not exist" ; - ok &$Func("<$tmpDir1/a*.tmp>" => $output), ' UnCompressed ok' - or diag $$Error ; - - ok -e $output, " $output does exist" ; - is readFile($output), join('', @expected), " got expected uncompressed data"; - } - - { - title "$TopType - From FileGlob to Filehandle" ; - - my $output = 'abc' ; - my $lex = new LexFile $output ; - my $fh = new IO::File ">$output" ; - ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1), ' UnCompressed ok' - or diag $$Error ; - - ok -e $output, " $output does exist" ; - is readFile($output), join('', @expected), " got expected uncompressed data"; - } - -} - -foreach my $TopType ('IO::Compress::Gzip::gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - # TODO -- add the inflate classes - ) -{ - my $Error = getErrorRef($TopType); - my $Func = getTopFuncRef($TopType); - my $Name = getTopFuncName($TopType); - - title "More write tests" ; - - my $lex = new LexFile(my $file1, my $file2, my $file3) ; - - writeFile($file1, "F1"); - writeFile($file2, "F2"); - writeFile($file3, "F3"); - - my @data = ( - [ '[]', "" ], - [ '[\""]', "" ], - [ '[\undef]', "" ], - [ '[\"abcd"]', "abcd" ], - [ '[\"ab", \"cd"]', "abcd" ], - - [ '$fh2', "F2" ], - [ '[\"a", $fh1, \"bc"]', "aF1bc"], - ) ; - - - foreach my $data (@data) - { - my ($send, $get) = @$data ; - - my $fh1 = new IO::File "< $file1" ; - my $fh2 = new IO::File "< $file2" ; - my $fh3 = new IO::File "< $file3" ; - - title "$send"; - my $copy; - eval "\$copy = $send"; - my $Answer ; - ok &$Func($copy, \$Answer), " $Name ok"; - - my $got = anyUncompress(\$Answer); - is $got, $get, " got expected output" ; - ok ! $$Error, " no error" - or diag "Error is $$Error"; - - } - - title "Array Input Error tests" ; - - @data = ( - '[[]]', - '[[[]]]', - '[[\"ab"], [\"cd"]]', - ) ; - - - foreach my $send (@data) - { - my $fh1 = new IO::File "< $file1" ; - my $fh2 = new IO::File "< $file2" ; - my $fh3 = new IO::File "< $file3" ; - - title "$send"; - my $copy; - eval "\$copy = $send"; - my $Answer ; - ok ! &$Func($copy, \$Answer), " $Name fails"; - - is $$Error, "unknown input parameter", " got error message"; - - } -} - -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))[8]; - # 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))[8]; - 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/Compress/Zlib/t/17isize.t b/ext/Compress/Zlib/t/17isize.t index 6882a84403..6e3fe5635b 100644 --- a/ext/Compress/Zlib/t/17isize.t +++ b/ext/Compress/Zlib/t/17isize.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } diff --git a/ext/Compress/Zlib/t/18lvalue.t b/ext/Compress/Zlib/t/18lvalue.t index 04b7f681c8..da01dcd8e9 100644 --- a/ext/Compress/Zlib/t/18lvalue.t +++ b/ext/Compress/Zlib/t/18lvalue.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } diff --git a/ext/Compress/Zlib/t/19destroy-deflate.t b/ext/Compress/Zlib/t/19destroy-deflate.t new file mode 100644 index 0000000000..9eb4e38bb9 --- /dev/null +++ b/ext/Compress/Zlib/t/19destroy-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/19destroy-gzip.t b/ext/Compress/Zlib/t/19destroy-gzip.t new file mode 100644 index 0000000000..d4ebc5998a --- /dev/null +++ b/ext/Compress/Zlib/t/19destroy-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/19destroy-rawdeflate.t b/ext/Compress/Zlib/t/19destroy-rawdeflate.t new file mode 100644 index 0000000000..3fb3dc4ded --- /dev/null +++ b/ext/Compress/Zlib/t/19destroy-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/19destroy-zip.t b/ext/Compress/Zlib/t/19destroy-zip.t new file mode 100644 index 0000000000..9998bb65d7 --- /dev/null +++ b/ext/Compress/Zlib/t/19destroy-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/20tied-deflate.t b/ext/Compress/Zlib/t/20tied-deflate.t new file mode 100644 index 0000000000..9542396d7b --- /dev/null +++ b/ext/Compress/Zlib/t/20tied-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/20tied-gzip.t b/ext/Compress/Zlib/t/20tied-gzip.t new file mode 100644 index 0000000000..082f6be130 --- /dev/null +++ b/ext/Compress/Zlib/t/20tied-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/20tied-rawdeflate.t b/ext/Compress/Zlib/t/20tied-rawdeflate.t new file mode 100644 index 0000000000..56d22a39ea --- /dev/null +++ b/ext/Compress/Zlib/t/20tied-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/20tied-zip.t b/ext/Compress/Zlib/t/20tied-zip.t new file mode 100644 index 0000000000..d186ff18ea --- /dev/null +++ b/ext/Compress/Zlib/t/20tied-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/20tied.t b/ext/Compress/Zlib/t/20tied.t deleted file mode 100644 index 3b18db1bd1..0000000000 --- a/ext/Compress/Zlib/t/20tied.t +++ /dev/null @@ -1,516 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib"); - } -} - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use ZlibTestUtils; - -our ($BadPerl); - -BEGIN -{ - plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" ) - if $] < 5.005 ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - my $tests ; - $BadPerl = ($] >= 5.006 or $] <= 5.008) ; - - if ($BadPerl) { - $tests = 731 ; - } - else { - $tests = 771 ; - } - - plan tests => $tests + $extra ; - - use_ok('Compress::Zlib', 2) ; - - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - - use_ok('IO::Compress::Deflate', qw($DeflateError)) ; - use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; - - use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; - use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; -} - - -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - - - - -our ($UncompressClass); - - -sub myGZreadFile -{ - my $filename = shift ; - my $init = shift ; - - - my $fil = new $UncompressClass $filename, - -Strict => 1, - -Append => 1 - ; - - my $data ; - $data = $init if defined $init ; - 1 while $fil->read($data) > 0; - - $fil->close ; - return $data ; -} - -# Check zlib_version and ZLIB_VERSION are the same. -is Compress::Zlib::zlib_version, ZLIB_VERSION, - "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; - - - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate') -{ - next if $BadPerl ; - - - title "Testing $CompressClass"; - - - my $x ; - my $gz = new $CompressClass(\$x); - - my $buff ; - - eval { getc($gz) } ; - like $@, mkErr("^getc Not Available: File opened only for output"); - - eval { read($gz, $buff, 1) } ; - like $@, mkErr("^read Not Available: File opened only for output"); - - eval { <$gz> } ; - like $@, mkErr("^readline Not Available: File opened only for output"); - -} - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate') -{ - next if $BadPerl; - $UncompressClass = getInverse($CompressClass); - - title "Testing $UncompressClass"; - - my $gc ; - my $guz = new $CompressClass(\$gc); - $guz->write("abc") ; - $guz->close(); - - my $x ; - my $gz = new $UncompressClass(\$gc); - - my $buff ; - - eval { print $gz "abc" } ; - like $@, mkErr("^print Not Available: File opened only for intput"); - - eval { printf $gz "fmt", "abc" } ; - like $@, mkErr("^printf Not Available: File opened only for intput"); - - #eval { write($gz, $buff, 1) } ; - #like $@, mkErr("^write Not Available: File opened only for intput"); - -} - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate') -{ - $UncompressClass = getInverse($CompressClass); - - title "Testing $CompressClass and $UncompressClass"; - - - { - # Write - # these tests come almost 100% from IO::String - - my $lex = new LexFile my $name ; - - my $io = $CompressClass->new($name); - - is $io->tell(), 0 ; - - my $heisan = "Heisan\n"; - print $io $heisan ; - - ok ! $io->eof; - - is $io->tell(), length($heisan) ; - - print($io "a", "b", "c"); - - { - local($\) = "\n"; - print $io "d", "e"; - local($,) = ","; - print $io "f", "g", "h"; - } - - my $foo = "1234567890"; - - ok syswrite($io, $foo, length($foo)) == length($foo) ; - if ( $[ < 5.6 ) - { is $io->syswrite($foo, length $foo), length $foo } - else - { is $io->syswrite($foo), length $foo } - ok $io->syswrite($foo, length($foo)) == length $foo; - ok $io->write($foo, length($foo), 5) == 5; - ok $io->write("xxx\n", 100, -1) == 1; - - for (1..3) { - printf $io "i(%d)", $_; - $io->printf("[%d]\n", $_); - } - select $io; - print "\n"; - select STDOUT; - - close $io ; - - ok $io->eof; - - is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . - ("1234567890" x 3) . "67890\n" . - "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; - - - } - - { - # Read - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - my $iow = new $CompressClass $name ; - print $iow $str ; - close $iow; - - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name ; - - ok ! $io->eof; - is $io->tell(), 0 ; - my @lines = <$io>; - is @lines, 6 - or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; - is $lines[1], "of a paragraph\n" ; - is join('', @lines), $str ; - is $., 6; - is $io->tell(), length($str) ; - - ok $io->eof; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined(<$io>) || - defined($io->getc) || - read($io, $buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - ok !$io->eof; - my @lines = $io->getlines; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = <$io>; - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = <$io>; - ok $io->eof; - ok @lines == 2 - or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# $lines[0]\n"; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (<$io>) { - push(@lines, $_); - $err++ if $. != ++$no; - } - - ok $err == 0 ; - ok $io->eof; - - ok @lines == 3 - or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test read - - { - my $io = $UncompressClass->new($name); - - - if (! $BadPerl) { - eval { read($io, $buf, -1) } ; - like $@, mkErr("length parameter is negative"); - } - - is read($io, $buf, 0), 0, "Requested 0 bytes" ; - - ok read($io, $buf, 3) == 3 ; - ok $buf eq "Thi"; - - ok sysread($io, $buf, 3, 2) == 3 ; - ok $buf eq "Ths i" - or print "# [$buf]\n" ;; - ok ! $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - } - - { - # Read from non-compressed file - - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - writeFile($name, $str); - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name, -Transparent => 1 ; - - ok defined $io; - ok ! $io->eof; - ok $io->tell() == 0 ; - my @lines = <$io>; - ok @lines == 6; - ok $lines[1] eq "of a paragraph\n" ; - ok join('', @lines) eq $str ; - ok $. == 6; - ok $io->tell() == length($str) ; - - ok $io->eof; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined(<$io>) || - defined($io->getc) || - read($io, $buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = <$io>; - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = <$io>; - ok $io->eof; - ok @lines == 2 - or print "# exected 2 lines, got " . scalar(@lines) . "\n"; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# [$lines[0]]\n" ; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (<$io>) { - push(@lines, $_); - $err++ if $. != ++$no; - } - - ok $err == 0 ; - ok $io->eof; - - ok @lines == 3 ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test read - - { - my $io = $UncompressClass->new($name); - - ok read($io, $buf, 3) == 3 ; - ok $buf eq "Thi"; - - ok sysread($io, $buf, 3, 2) == 3 ; - ok $buf eq "Ths i"; - ok ! $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - - } - - { - # Vary the length parameter in a read - - my $str = <<EOT; -x -x -This is an example -of a paragraph - - -and a single line. - -EOT - $str = $str x 100 ; - - - foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) - { - foreach my $trans (0, 1) - { - foreach my $append (0, 1) - { - title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; - - my $lex = new LexFile my $name ; - - if ($trans) { - writeFile($name, $str) ; - } - else { - my $iow = new $CompressClass $name ; - print $iow $str ; - close $iow; - } - - - my $io = $UncompressClass->new($name, - -Append => $append, - -Transparent => $trans); - - my $buf; - - is $io->tell(), 0; - - if ($append) { - 1 while $io->read($buf, $bufsize) > 0; - } - else { - my $tmp ; - $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; - } - is length $buf, length $str; - ok $buf eq $str ; - ok ! $io->error() ; - ok $io->eof; - } - } - } - } - -} diff --git a/ext/Compress/Zlib/t/21newtied-deflate.t b/ext/Compress/Zlib/t/21newtied-deflate.t new file mode 100644 index 0000000000..cb82af857f --- /dev/null +++ b/ext/Compress/Zlib/t/21newtied-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/21newtied-gzip.t b/ext/Compress/Zlib/t/21newtied-gzip.t new file mode 100644 index 0000000000..4402b56a91 --- /dev/null +++ b/ext/Compress/Zlib/t/21newtied-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/21newtied-rawdeflate.t b/ext/Compress/Zlib/t/21newtied-rawdeflate.t new file mode 100644 index 0000000000..5e93bb04d3 --- /dev/null +++ b/ext/Compress/Zlib/t/21newtied-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/21newtied-zip.t b/ext/Compress/Zlib/t/21newtied-zip.t new file mode 100644 index 0000000000..f0b0d70c44 --- /dev/null +++ b/ext/Compress/Zlib/t/21newtied-zip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/21newtied.t b/ext/Compress/Zlib/t/21newtied.t deleted file mode 100644 index eb642b6c0b..0000000000 --- a/ext/Compress/Zlib/t/21newtied.t +++ /dev/null @@ -1,396 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib"); - } -} - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use ZlibTestUtils; - -our ($BadPerl); - -BEGIN -{ - plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" ) - if $] < 5.006 ; - - my $tests ; - - $BadPerl = ($] >= 5.006 or $] <= 5.008) ; - - if ($BadPerl) { - $tests = 242 ; - } - else { - $tests = 242 ; - } - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => $tests + $extra ; - - use_ok('Compress::Zlib', 2) ; - - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - - use_ok('IO::Compress::Deflate', qw($DeflateError)) ; - use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; - - use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; - use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; - - -} - - -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - - -our ($UncompressClass); - - -sub myGZreadFile -{ - my $filename = shift ; - my $init = shift ; - - - my $fil = new $UncompressClass $filename, - -Strict => 1, - -Append => 1 - ; - - my $data ; - $data = $init if defined $init ; - 1 while $fil->read($data) > 0; - - $fil->close ; - return $data ; -} - -# Check zlib_version and ZLIB_VERSION are the same. -is Compress::Zlib::zlib_version, ZLIB_VERSION, - "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; - - - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - $UncompressClass = getInverse($CompressClass); - - title "Testing $CompressClass and $UncompressClass"; - - - - { - # Write - # these tests come almost 100% from IO::String - - my $lex = new LexFile my $name ; - - my $io = $CompressClass->new($name); - - is tell($io), 0 ; - is $io->tell(), 0 ; - - my $heisan = "Heisan\n"; - print $io $heisan ; - - ok ! eof($io); - ok ! $io->eof(); - - is tell($io), length($heisan) ; - is $io->tell(), length($heisan) ; - - $io->print("a", "b", "c"); - - { - local($\) = "\n"; - print $io "d", "e"; - local($,) = ","; - print $io "f", "g", "h"; - } - - my $foo = "1234567890"; - - ok syswrite($io, $foo, length($foo)) == length($foo) ; - if ( $[ < 5.6 ) - { is $io->syswrite($foo, length $foo), length $foo } - else - { is $io->syswrite($foo), length $foo } - ok $io->syswrite($foo, length($foo)) == length $foo; - ok $io->write($foo, length($foo), 5) == 5; - ok $io->write("xxx\n", 100, -1) == 1; - - for (1..3) { - printf $io "i(%d)", $_; - $io->printf("[%d]\n", $_); - } - select $io; - print "\n"; - select STDOUT; - - close $io ; - - ok eof($io); - ok $io->eof(); - - is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . - ("1234567890" x 3) . "67890\n" . - "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; - - - } - - { - # Read - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - my $iow = new $CompressClass $name ; - print $iow $str ; - close $iow; - - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name ; - - ok ! $io->eof; - ok ! eof $io; - is $io->tell(), 0 ; - is tell($io), 0 ; - my @lines = <$io>; - is @lines, 6 - or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; - is $lines[1], "of a paragraph\n" ; - is join('', @lines), $str ; - is $., 6; - #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ; - is $io->tell(), length($str) ; - is tell($io), length($str) ; - - ok $io->eof; - ok eof $io; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined(<$io>) || - defined($io->getc) || - read($io, $buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = <$io>; - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = <$io>; - ok $io->eof; - ok @lines == 2 - or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# $lines[0]\n"; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (<$io>) { - push(@lines, $_); - $err++ if $. != ++$no; - } - - ok $err == 0 ; - ok $io->eof; - - ok @lines == 3 - or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test read - - { - my $io = $UncompressClass->new($name); - - ok $io, "opened ok" ; - - #eval { read($io, $buf, -1); } ; - #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ; - - #eval { read($io, 1) } ; - #like $@, mkErr("buffer parameter is read-only"); - - is read($io, $buf, 0), 0, "Requested 0 bytes" ; - - ok read($io, $buf, 3) == 3 ; - ok $buf eq "Thi"; - - ok sysread($io, $buf, 3, 2) == 3 ; - ok $buf eq "Ths i" - or print "# [$buf]\n" ;; - ok ! $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - } - - - - { - title "seek tests" ; - - my $lex = new LexFile my $name ; - - my $first = "beginning" ; - my $last = "the end" ; - my $iow = new $CompressClass $name ; - print $iow $first ; - ok seek $iow, 10, SEEK_CUR ; - is tell($iow), length($first)+10; - ok $iow->seek(0, SEEK_CUR) ; - is tell($iow), length($first)+10; - print $iow $last ; - close $iow; - - my $io = $UncompressClass->new($name); - ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ; - - $io = $UncompressClass->new($name); - ok seek $io, length($first)+10, SEEK_CUR ; - ok ! $io->eof; - is tell($io), length($first)+10; - ok seek $io, 0, SEEK_CUR ; - is tell($io), length($first)+10; - my $buff ; - ok read $io, $buff, 100 ; - ok $buff eq $last ; - ok $io->eof; - } - - if (! $BadPerl) - { - # seek error cases - my $b ; - my $a = new $CompressClass(\$b) ; - - ok ! $a->error() ; - eval { seek($a, -1, 10) ; }; - like $@, mkErr("^seek: unknown value, 10, for whence parameter"); - - eval { seek($a, -1, SEEK_END) ; }; - like $@, mkErr("^cannot seek backwards"); - - print $a "fred"; - close $a ; - - - my $u = new $UncompressClass(\$b) ; - - eval { seek($u, -1, 10) ; }; - like $@, mkErr("^seek: unknown value, 10, for whence parameter"); - - eval { seek($u, -1, SEEK_END) ; }; - like $@, mkErr("^seek: SEEK_END not allowed"); - - eval { seek($u, -1, SEEK_CUR) ; }; - like $@, mkErr("^cannot seek backwards"); - } - - { - title 'fileno' ; - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - my $fh ; - ok $fh = new IO::File ">$name" ; - my $x ; - ok $x = new $CompressClass $fh ; - - ok $x->fileno() == fileno($fh) ; - ok $x->fileno() == fileno($x) ; - ok $x->write($hello) ; - ok $x->close ; - $fh->close() ; - } - - my $uncomp; - { - my $x ; - ok my $fh1 = new IO::File "<$name" ; - ok $x = new $UncompressClass $fh1, -Append => 1 ; - ok $x->fileno() == fileno $fh1 ; - ok $x->fileno() == fileno $x ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close ; - } - - ok $hello eq $uncomp ; - } -} - diff --git a/ext/Compress/Zlib/t/22merge-deflate.t b/ext/Compress/Zlib/t/22merge-deflate.t new file mode 100644 index 0000000000..5ac93923af --- /dev/null +++ b/ext/Compress/Zlib/t/22merge-deflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/22merge-gzip.t b/ext/Compress/Zlib/t/22merge-gzip.t new file mode 100644 index 0000000000..045eb04781 --- /dev/null +++ b/ext/Compress/Zlib/t/22merge-gzip.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/22merge-rawdeflate.t b/ext/Compress/Zlib/t/22merge-rawdeflate.t new file mode 100644 index 0000000000..761efc4031 --- /dev/null +++ b/ext/Compress/Zlib/t/22merge-rawdeflate.t @@ -0,0 +1,21 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/22merge-zip.t b/ext/Compress/Zlib/t/22merge-zip.t new file mode 100644 index 0000000000..4efa1d1acd --- /dev/null +++ b/ext/Compress/Zlib/t/22merge-zip.t @@ -0,0 +1,24 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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(); diff --git a/ext/Compress/Zlib/t/22merge.t b/ext/Compress/Zlib/t/22merge.t deleted file mode 100644 index 4389f3e369..0000000000 --- a/ext/Compress/Zlib/t/22merge.t +++ /dev/null @@ -1,359 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib"); - } -} - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use ZlibTestUtils; - -our ($extra); -use Compress::Zlib 2 ; - -use IO::Compress::Gzip qw($GzipError); -use IO::Uncompress::Gunzip qw($GunzipError); - -use IO::Compress::Deflate qw($DeflateError); -use IO::Uncompress::Inflate qw($InflateError); - -use IO::Compress::RawDeflate qw($RawDeflateError); -use IO::Uncompress::RawInflate qw($RawInflateError); - - -BEGIN -{ - plan(skip_all => "Merge needs Zlib 1.2.1 or better - you have Zlib " - . Compress::Zlib::zlib_version()) - if ZLIB_VERNUM() < 0x1210 ; - - # use Test::NoWarnings, if available - $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 490 + $extra ; - -} - - -# Check zlib_version and ZLIB_VERSION are the same. -is Compress::Zlib::zlib_version, ZLIB_VERSION, - "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; - -# Tests -# destination is a file that doesn't exist -- should work ok unless AnyDeflate -# destination isn't compressed at all -# destination is compressed but wrong format -# destination is corrupt - error messages should be correct -# use apend mode with old zlib - check that this is trapped -# destination is not seekable, readable, writable - test for filename & handle - -{ - title "Misc error cases"; - - eval { new Compress::Zlib::InflateScan Bufsize => 0} ; - like $@, mkErr("^Compress::Zlib::InflateScan::new: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0"; - - eval { Compress::Zlib::inflateScanStream::createDeflateStream(undef, Bufsize => 0) } ; - like $@, mkErr("^Compress::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0"; - -} - -# output file/handle not writable -foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) -{ - - my $Error = getErrorRef($CompressClass); - - foreach my $to_file (0,1) - { - if ($to_file) - { title "$CompressClass - Merge to filename that isn't writable" } - else - { title "$CompressClass - Merge to filehandle that isn't writable" } - - my $lex = new LexFile my $out_file ; - - # create empty file - open F, ">$out_file" ; print F "x"; close F; - ok -e $out_file, " file exists" ; - ok !-z $out_file, " and is not empty" ; - - # make unwritable - is chmod(0444, $out_file), 1, " chmod worked" ; - ok -e $out_file, " still exists after chmod" ; - - SKIP: - { - skip "Cannot create non-writable file", 3 - if -w $out_file ; - - ok ! -w $out_file, " chmod made file unwritable" ; - - my $dest ; - if ($to_file) - { $dest = $out_file } - else - { $dest = new IO::File "<$out_file" } - - my $gz = $CompressClass->new($dest, Merge => 1) ; - - ok ! $gz, " Did not create $CompressClass object"; - - { - if ($to_file) { - is $$Error, "Output file '$out_file' is not writable", - " Got non-writable filename message" ; - } - else { - is $$Error, "Output filehandle is not writable", - " Got non-writable filehandle message" ; - } - } - } - - chmod 0777, $out_file ; - } -} - -# output is not compressed at all -foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) -{ - - my $Error = getErrorRef($CompressClass); - - my $lex = new LexFile my $out_file ; - - foreach my $to_file ( qw(buffer file handle ) ) - { - title "$CompressClass to $to_file, content is not compressed"; - - my $content = "abc" x 300 ; - my $buffer ; - my $disp_content = defined $content ? $content : '<undef>' ; - my $str_content = defined $content ? $content : '' ; - - if ($to_file eq 'buffer') - { - $buffer = \$content ; - } - else - { - writeFile($out_file, $content); - - if ($to_file eq 'handle') - { - $buffer = new IO::File "+<$out_file" - or die "# Cannot open $out_file: $!"; - } - else - { $buffer = $out_file } - } - - ok ! $CompressClass->new($buffer, Merge => 1), " constructor fails"; - { - like $$Error, '/Cannot create InflateScan object: (Header Error|unexpected end of file)/', " got Bad Magic" ; - } - - } -} - -# output is empty -foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) -{ - - my $Error = getErrorRef($CompressClass); - - my $lex = new LexFile my $out_file ; - - foreach my $to_file ( qw(buffer file handle ) ) - { - title "$CompressClass to $to_file, content is empty"; - - my $content = ''; - my $buffer ; - my $dest ; - - if ($to_file eq 'buffer') - { - $dest = $buffer = \$content ; - } - else - { - writeFile($out_file, $content); - $dest = $out_file; - - if ($to_file eq 'handle') - { - $buffer = new IO::File "+<$out_file" - or die "# Cannot open $out_file: $!"; - } - else - { $buffer = $out_file } - } - - ok my $gz = $CompressClass->new($buffer, Merge => 1, AutoClose => 1), " constructor passes"; - - $gz->write("FGHI"); - $gz->close(); - - #hexDump($buffer); - my $out = anyUncompress($dest); - - is $out, "FGHI", ' Merge OK'; - } -} - -foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) -{ - my $Error = getErrorRef($CompressClass); - - title "$CompressClass - Merge to file that doesn't exist"; - - my $lex = new LexFile my $out_file ; - - ok ! -e $out_file, " Destination file, '$out_file', does not exist"; - - ok my $gz1 = $CompressClass->new($out_file, Merge => 1) - or die "# $CompressClass->new failed: $GzipError\n"; - #hexDump($buffer); - $gz1->write("FGHI"); - $gz1->close(); - - #hexDump($buffer); - my $out = anyUncompress($out_file); - - is $out, "FGHI", ' Merged OK'; -} - -foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) -{ - my $Error = getErrorRef($CompressClass); - - my $lex = new LexFile my $out_file ; - - foreach my $to_file ( qw( buffer file handle ) ) - { - foreach my $content (undef, '', 'x', 'abcde') - { - #next if ! defined $content && $to_file; - - my $buffer ; - my $disp_content = defined $content ? $content : '<undef>' ; - my $str_content = defined $content ? $content : '' ; - - if ($to_file eq 'buffer') - { - my $x ; - $buffer = \$x ; - title "$CompressClass to Buffer, content is '$disp_content'"; - } - else - { - $buffer = $out_file ; - if ($to_file eq 'handle') - { - title "$CompressClass to Filehandle, content is '$disp_content'"; - } - else - { - title "$CompressClass to File, content is '$disp_content'"; - } - } - - my $gz = $CompressClass->new($buffer); - my $len = defined $content ? length($content) : 0 ; - is $gz->write($content), $len, " write ok"; - ok $gz->close(), " close ok"; - - #hexDump($buffer); - is anyUncompress($buffer), $str_content, ' Destination is ok'; - - #if ($corruption) - #{ - # next if $TopTypes eq 'RawDeflate' && $content eq ''; - # - #} - - my $dest = $buffer ; - if ($to_file eq 'handle') - { - $dest = new IO::File "+<$buffer" ; - } - - my $gz1 = $CompressClass->new($dest, Merge => 1, AutoClose => 1) - or die "## Error is $$Error\n"; - - #print "YYY\n"; - #hexDump($buffer); - #print "XXX\n"; - is $gz1->write("FGHI"), 4, " write returned 4"; - ok $gz1->close(), " close ok"; - - #hexDump($buffer); - my $out = anyUncompress($buffer); - - is $out, $str_content . "FGHI", ' Merged OK'; - #exit; - } - } - -} - - - -foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) -{ - my $Error = getErrorRef($CompressClass); - - my $Func = getTopFuncRef($CompressClass); - my $TopType = getTopFuncName($CompressClass); - - my $buffer ; - - my $lex = new LexFile my $out_file ; - - foreach my $to_file (0, 1) - { - foreach my $content (undef, '', 'x', 'abcde') - { - my $disp_content = defined $content ? $content : '<undef>' ; - my $str_content = defined $content ? $content : '' ; - my $buffer ; - if ($to_file) - { - $buffer = $out_file ; - title "$TopType to File, content is '$disp_content'"; - } - else - { - my $x = ''; - $buffer = \$x ; - title "$TopType to Buffer, content is '$disp_content'"; - } - - - ok $Func->(\$content, $buffer), " Compress content"; - #hexDump($buffer); - is anyUncompress($buffer), $str_content, ' Destination is ok'; - - - ok $Func->(\"FGHI", $buffer, Merge => 1), " Merge content"; - - #hexDump($buffer); - my $out = anyUncompress($buffer); - - is $out, $str_content . "FGHI", ' Merged OK'; - } - } - -} - - - diff --git a/ext/Compress/Zlib/t/23misc.t b/ext/Compress/Zlib/t/23misc.t index a830b966bf..9889174087 100644 --- a/ext/Compress/Zlib/t/23misc.t +++ b/ext/Compress/Zlib/t/23misc.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } @@ -19,23 +19,13 @@ BEGIN { $extra = 1 if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - plan tests => 29 + $extra ; + plan tests => 30 + $extra ; use_ok('Compress::Zlib::Common'); use_ok('Compress::Zlib::ParseParameters'); -# use_ok('Compress::Zlib', 2) ; -# -# use_ok('IO::Compress::Gzip', qw($GzipError)) ; -# use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; -# -# use_ok('IO::Compress::Deflate', qw($DeflateError)) ; -# use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; -# -# use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; -# use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; } @@ -55,22 +45,26 @@ sub My::testParseParameters() like $@, mkErr(': Expected even number of parameters, got 1'), "Trap odd number of params"; - eval { ParseParameters(1, {'Fred' => [Parse_unsigned, 0]}, Fred => undef) ; }; - like $@, mkErr("Parameter 'Fred' must be an unsigned int, got undef"), + eval { ParseParameters(1, {'Fred' => [1, 1, Parse_boolean, 0]}, Fred => 'joe') ; }; + like $@, mkErr("Parameter 'Fred' must be an int, got 'joe'"), "wanted unsigned, got undef"; - eval { ParseParameters(1, {'Fred' => [Parse_signed, 0]}, Fred => undef) ; }; - like $@, mkErr("Parameter 'Fred' must be a signed int, got undef"), + eval { ParseParameters(1, {'Fred' => [1, 1, Parse_unsigned, 0]}, Fred => undef) ; }; + like $@, mkErr("Parameter 'Fred' must be an unsigned int, got 'undef'"), + "wanted unsigned, got undef"; + + eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => undef) ; }; + like $@, mkErr("Parameter 'Fred' must be a signed int, got 'undef'"), "wanted signed, got undef"; - eval { ParseParameters(1, {'Fred' => [Parse_signed, 0]}, Fred => 'abc') ; }; + eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => 'abc') ; }; like $@, mkErr("Parameter 'Fred' must be a signed int, got 'abc'"), "wanted signed, got 'abc'"; - my $got = ParseParameters(1, {'Fred' => [Parse_store_ref, 0]}, Fred => 'abc') ; + my $got = ParseParameters(1, {'Fred' => [1, 1, Parse_store_ref, 0]}, Fred => 'abc') ; is ${ $got->value('Fred') }, "abc", "Parse_store_ref" ; - $got = ParseParameters(1, {'Fred' => [0x1000000, 0]}, Fred => 'abc') ; + $got = ParseParameters(1, {'Fred' => [1, 1, 0x1000000, 0]}, Fred => 'abc') ; is $got->value('Fred'), "abc", "other" ; } diff --git a/ext/Compress/Zlib/t/25anyunc-deflate.t b/ext/Compress/Zlib/t/25anyunc-deflate.t new file mode 100644 index 0000000000..40ebc6387e --- /dev/null +++ b/ext/Compress/Zlib/t/25anyunc-deflate.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/25anyunc-gzip.t b/ext/Compress/Zlib/t/25anyunc-gzip.t new file mode 100644 index 0000000000..33dd803f2c --- /dev/null +++ b/ext/Compress/Zlib/t/25anyunc-gzip.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/25anyunc-rawdeflate.t b/ext/Compress/Zlib/t/25anyunc-rawdeflate.t new file mode 100644 index 0000000000..e85c72ec42 --- /dev/null +++ b/ext/Compress/Zlib/t/25anyunc-rawdeflate.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/25anyunc-transparent.t b/ext/Compress/Zlib/t/25anyunc-transparent.t new file mode 100644 index 0000000000..9b35df0546 --- /dev/null +++ b/ext/Compress/Zlib/t/25anyunc-transparent.t @@ -0,0 +1,72 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; + +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +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/Compress/Zlib/t/25anyunc-zip.t b/ext/Compress/Zlib/t/25anyunc-zip.t new file mode 100644 index 0000000000..efaf0ae286 --- /dev/null +++ b/ext/Compress/Zlib/t/25anyunc-zip.t @@ -0,0 +1,29 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +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/Compress/Zlib/t/99pod.t b/ext/Compress/Zlib/t/99pod.t new file mode 100644 index 0000000000..5ffa0264f0 --- /dev/null +++ b/ext/Compress/Zlib/t/99pod.t @@ -0,0 +1,16 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib 't'; +use Test::More; + +eval "use Test::Pod 1.00"; + +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +all_pod_files_ok(); + diff --git a/ext/Compress/Zlib/t/globmapper.t b/ext/Compress/Zlib/t/globmapper.t index 93c650673b..75b7baf025 100644 --- a/ext/Compress/Zlib/t/globmapper.t +++ b/ext/Compress/Zlib/t/globmapper.t @@ -1,7 +1,7 @@ BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; - @INC = ("../lib", "lib"); + @INC = ("../lib", "lib/compress"); } } diff --git a/t/lib/ZlibTestUtils.pm b/t/lib/compress/ZlibTestUtils.pm index 7d044beead..c8e405d909 100644 --- a/t/lib/ZlibTestUtils.pm +++ b/t/lib/compress/ZlibTestUtils.pm @@ -82,7 +82,7 @@ sub readFile else { open (F, "<$f") - or die "Cannot open $f: $!\n" ; + or croak "Cannot open $f: $!\n" ; @strings = <F> ; close F ; } @@ -99,8 +99,9 @@ sub touch sub writeFile { my($filename, @strings) = @_ ; + 1 while unlink $filename ; open (F, ">$filename") - or die "Cannot open $filename: $!\n" ; + or croak "Cannot open $filename: $!\n" ; binmode F; foreach (@strings) { no warnings ; @@ -116,7 +117,7 @@ sub GZreadFile my ($uncomp) = "" ; my $line = "" ; my $fil = gzopen($filename, "rb") - or die "Cannopt open '$filename': $Compress::Zlib::gzerrno" ; + or croak "Cannopt open '$filename': $Compress::Zlib::gzerrno" ; $uncomp .= $line while $fil->gzread($line) > 0; @@ -177,7 +178,7 @@ EOM ok $x->write($string) ; ok $x->close ; - ok GZreadFile($name) eq $string ; + is GZreadFile($name), $string ; ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0 or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; @@ -201,12 +202,18 @@ sub uncompressBuffer my $compWith = shift ; my $buffer = shift ; - my %mapping = ( 'IO::Compress::Gzip' => 'IO::Uncompress::Gunzip', + my %mapping = ( 'IO::Compress::Gzip' => 'IO::Uncompress::Gunzip', 'IO::Compress::Gzip::gzip' => 'IO::Uncompress::Gunzip', 'IO::Compress::Deflate' => 'IO::Uncompress::Inflate', 'IO::Compress::Deflate::deflate' => 'IO::Uncompress::Inflate', 'IO::Compress::RawDeflate' => 'IO::Uncompress::RawInflate', 'IO::Compress::RawDeflate::rawdeflate' => 'IO::Uncompress::RawInflate', + 'IO::Compress::Bzip2' => 'IO::Uncompress::Bunzip2', + 'IO::Compress::Bzip2::bzip2' => 'IO::Uncompress::Bunzip2', + 'IO::Compress::Zip' => 'IO::Uncompress::Unzip', + 'IO::Compress::Zip::zip' => 'IO::Uncompress::Unzip', + 'IO::Compress::Lzop' => 'IO::Uncompress::UnLzop', + 'IO::Compress::Lzop::lzop' => 'IO::Uncompress::UnLzop', ); my $out ; @@ -216,29 +223,55 @@ sub uncompressBuffer } -my %ErrorMap = ( 'IO::Compress::Gzip' => \$IO::Compress::Gzip::GzipError, - 'IO::Compress::Gzip::gzip' => \$IO::Compress::Gzip::GzipError, - 'IO::Uncompress::Gunzip' => \$IO::Uncompress::Gunzip::GunzipError, - 'IO::Uncompress::Gunzip::gunzip' => \$IO::Uncompress::Gunzip::GunzipError, - 'IO::Uncompress::Inflate' => \$IO::Uncompress::Inflate::InflateError, +my %ErrorMap = ( 'IO::Compress::Gzip' => \$IO::Compress::Gzip::GzipError, + 'IO::Compress::Gzip::gzip' => \$IO::Compress::Gzip::GzipError, + 'IO::Uncompress::Gunzip' => \$IO::Uncompress::Gunzip::GunzipError, + 'IO::Uncompress::Gunzip::gunzip' => \$IO::Uncompress::Gunzip::GunzipError, + 'IO::Uncompress::Inflate' => \$IO::Uncompress::Inflate::InflateError, 'IO::Uncompress::Inflate::inflate' => \$IO::Uncompress::Inflate::InflateError, - 'IO::Compress::Deflate' => \$IO::Compress::Deflate::DeflateError, - 'IO::Compress::Deflate::deflate' => \$IO::Compress::Deflate::DeflateError, - 'IO::Uncompress::RawInflate' => \$IO::Uncompress::RawInflate::RawInflateError, + 'IO::Compress::Deflate' => \$IO::Compress::Deflate::DeflateError, + 'IO::Compress::Deflate::deflate' => \$IO::Compress::Deflate::DeflateError, + 'IO::Uncompress::RawInflate' => \$IO::Uncompress::RawInflate::RawInflateError, 'IO::Uncompress::RawInflate::rawinflate' => \$IO::Uncompress::RawInflate::RawInflateError, - 'IO::Uncompress::AnyInflate' => \$IO::Uncompress::AnyInflate::AnyInflateError, + 'IO::Uncompress::AnyInflate' => \$IO::Uncompress::AnyInflate::AnyInflateError, 'IO::Uncompress::AnyInflate::anyinflate' => \$IO::Uncompress::AnyInflate::AnyInflateError, - 'IO::Compress::RawDeflate' => \$IO::Compress::RawDeflate::RawDeflateError, + 'IO::Uncompress::AnyUncompress' => \$IO::Uncompress::AnyUncompress::AnyUncompressError, + 'IO::Uncompress::AnyUncompress::anyUncompress' => \$IO::Uncompress::AnyUncompress::AnyUncompressError, + 'IO::Compress::RawDeflate' => \$IO::Compress::RawDeflate::RawDeflateError, 'IO::Compress::RawDeflate::rawdeflate' => \$IO::Compress::RawDeflate::RawDeflateError, + 'IO::Compress::Bzip2' => \$IO::Compress::Bzip2::Bzip2Error, + 'IO::Compress::Bzip2::bzip2' => \$IO::Compress::Bzip2::Bzip2Error, + 'IO::Uncompress::Bunzip2' => \$IO::Uncompress::Bunzip2::Bunzip2Error, + 'IO::Uncompress::Bunzip2::bunzip2' => \$IO::Uncompress::Bunzip2::Bunzip2Error, + 'IO::Compress::Zip' => \$IO::Compress::Zip::ZipError, + 'IO::Compress::Zip::zip' => \$IO::Compress::Zip::ZipError, + 'IO::Uncompress::Unzip' => \$IO::Uncompress::Unzip::UnzipError, + 'IO::Uncompress::Unzip::unzip' => \$IO::Uncompress::Unzip::UnzipError, + 'IO::Compress::Lzop' => \$IO::Compress::Lzop::LzopError, + 'IO::Compress::Lzop::lzop' => \$IO::Compress::Lzop::LzopError, + 'IO::Uncompress::UnLzop' => \$IO::Uncompress::UnLzop::UnLzopError, + 'IO::Uncompress::UnLzop::unlzop' => \$IO::Uncompress::UnLzop::UnLzopError, ); -my %TopFuncMap = ( 'IO::Compress::Gzip' => 'IO::Compress::Gzip::gzip', +my %TopFuncMap = ( 'IO::Compress::Gzip' => 'IO::Compress::Gzip::gzip', 'IO::Uncompress::Gunzip' => 'IO::Uncompress::Gunzip::gunzip', - 'IO::Compress::Deflate' => 'IO::Compress::Deflate::deflate', + + 'IO::Compress::Deflate' => 'IO::Compress::Deflate::deflate', 'IO::Uncompress::Inflate' => 'IO::Uncompress::Inflate::inflate', - 'IO::Compress::RawDeflate' => 'IO::Compress::RawDeflate::rawdeflate', + + 'IO::Compress::RawDeflate' => 'IO::Compress::RawDeflate::rawdeflate', 'IO::Uncompress::RawInflate' => 'IO::Uncompress::RawInflate::rawinflate', + 'IO::Uncompress::AnyInflate' => 'IO::Uncompress::AnyInflate::anyinflate', + 'IO::Uncompress::AnyUncompress' => 'IO::Uncompress::AnyUncompress::anyuncompress', + + 'IO::Compress::Bzip2' => 'IO::Compress::Bzip2::bzip2', + 'IO::Uncompress::Bunzip2' => 'IO::Uncompress::Bunzip2::bunzip2', + + 'IO::Compress::Zip' => 'IO::Compress::Zip::zip', + 'IO::Uncompress::Unzip' => 'IO::Uncompress::Unzip::unzip', + 'IO::Compress::Lzop' => 'IO::Compress::Lzop::lzop', + 'IO::Uncompress::UnLzop' => 'IO::Uncompress::UnLzop::unlzop', ); %TopFuncMap = map { ($_ => $TopFuncMap{$_}, @@ -255,6 +288,12 @@ my %inverse = ( 'IO::Compress::Gzip' => 'IO::Uncompress::Gun 'IO::Compress::Deflate::deflate' => 'IO::Uncompress::Inflate::inflate', 'IO::Compress::RawDeflate' => 'IO::Uncompress::RawInflate', 'IO::Compress::RawDeflate::rawdeflate' => 'IO::Uncompress::RawInflate::rawinflate', + 'IO::Compress::Bzip2::bzip2' => 'IO::Uncompress::Bunzip2::bunzip2', + 'IO::Compress::Bzip2' => 'IO::Uncompress::Bunzip2', + 'IO::Compress::Zip::zip' => 'IO::Uncompress::Unzip::unzip', + 'IO::Compress::Zip' => 'IO::Uncompress::Unzip', + 'IO::Compress::Lzop::lzop' => 'IO::Uncompress::UnLzop::unlzop', + 'IO::Compress::Lzop' => 'IO::Uncompress::UnLzop', ); %inverse = map { ($_ => $inverse{$_}, $inverse{$_} => $_) } keys %inverse; @@ -298,8 +337,16 @@ sub compressBuffer 'IO::Uncompress::Inflate::inflate' => 'IO::Compress::Deflate', 'IO::Uncompress::RawInflate' => 'IO::Compress::RawDeflate', 'IO::Uncompress::RawInflate::rawinflate' => 'IO::Compress::RawDeflate', + 'IO::Uncompress::Bunzip2' => 'IO::Compress::Bzip2', + 'IO::Uncompress::Bunzip2::bunzip2' => 'IO::Compress::Bzip2', + 'IO::Uncompress::Unzip' => 'IO::Compress::Zip', + 'IO::Uncompress::Unzip::unzip' => 'IO::Compress::Zip', + 'IO::Uncompress::UnLzop' => 'IO::Compress::Lzop', + 'IO::Uncompress::UnLzop::unlzop' => 'IO::Compress::Lzop', 'IO::Uncompress::AnyInflate' => 'IO::Compress::Gzip', 'IO::Uncompress::AnyInflate::anyinflate' => 'IO::Compress::Gzip', + 'IO::Uncompress::AnyUncompress' => 'IO::Compress::Gzip', + 'IO::Uncompress::AnyUncompress::anyuncompress' => 'IO::Compress::Gzip', ); my $out ; @@ -310,7 +357,7 @@ sub compressBuffer } -use IO::Uncompress::AnyInflate qw($AnyInflateError); +use IO::Uncompress::AnyUncompress qw($AnyUncompressError); sub anyUncompress { my $buffer = shift ; @@ -355,8 +402,8 @@ sub anyUncompress } my $out = ''; - my $o = new IO::Uncompress::AnyInflate \$data, -Append => 1, Transparent => 0, @opts - or croak "Cannot open buffer/file: $AnyInflateError" ; + my $o = new IO::Uncompress::AnyUncompress \$data, -Append => 1, Transparent => 0, @opts + or croak "Cannot open buffer/file: $AnyUncompressError" ; 1 while $o->read($out) > 0 ; @@ -367,6 +414,99 @@ sub anyUncompress } +sub getHeaders +{ + my $buffer = shift ; + my $already = shift; + + my @opts = (); + if (ref $buffer && ref $buffer eq 'ARRAY') + { + @opts = @$buffer; + $buffer = shift @opts; + } + + if (ref $buffer) + { + croak "buffer is undef" unless defined $$buffer; + croak "buffer is empty" unless length $$buffer; + + } + + + my $data ; + if (Compress::Zlib::Common::isaFilehandle($buffer)) + { + $data = readFile($buffer); + } + elsif (Compress::Zlib::Common::isaFilename($buffer)) + { + $data = readFile($buffer); + } + else + { + $data = $$buffer ; + } + + if (defined $already && length $already) + { + + my $got = substr($data, 0, length($already)); + substr($data, 0, length($already)) = ''; + + is $got, $already, ' Already OK' ; + } + + my $out = ''; + my $o = new IO::Uncompress::AnyUncompress \$data, MultiStream => 1, -Append => 1, Transparent => 0, @opts + or croak "Cannot open buffer/file: $AnyUncompressError" ; + + 1 while $o->read($out) > 0 ; + + croak "Error uncompressing -- " . $o->error() + if $o->error() ; + + return ($o->getHeaderInfo()) ; + +} + +sub mkComplete +{ + my $class = shift ; + my $data = shift; + my $Error = getErrorRef($class); + + my $buffer ; + my %params = (); + + if ($class eq 'IO::Compress::Gzip') { + %params = ( + -Name => "My name", + -Comment => "a comment", + -ExtraField => ['ab' => "extra"], + -HeaderCRC => 1); + } + elsif ($class eq 'IO::Compress::Zip'){ + %params = ( + # TODO -- add more here + -Name => "My name", + -Comment => "a comment", + ); + } + + my $z = new $class( \$buffer, %params) + or croak "Cannot create $class object: $$Error"; + $z->write($data); + $z->close(); + + my $unc = getInverse($class); + my $u = new $unc( \$buffer); + my $info = $u->getHeaderInfo() ; + + + return wantarray ? ($info, $buffer) : $buffer ; +} + sub mkErr { my $string = shift ; @@ -375,14 +515,16 @@ sub mkErr $file = quotemeta($file); - return "/$string\\s+at $file line $line/" ; + return "/$string\\s+at $file line $line/" if $] >= 5.006 ; + return "/$string\\s+at /" ; } sub mkEvalErr { my $string = shift ; - return "/$string\\s+at \\(eval /" ; + return "/$string\\s+at \\(eval /" if $] > 5.006 ; + return "/$string\\s+at /" ; } sub dumpObj diff --git a/t/lib/compress/any.pl b/t/lib/compress/any.pl new file mode 100644 index 0000000000..065fedbb58 --- /dev/null +++ b/t/lib/compress/any.pl @@ -0,0 +1,74 @@ + +use lib 't'; + +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 36 + $extra ; + +} + +sub run +{ + my $CompressClass = identify(); + my $AnyClass = getClass(); + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + my $AnyConstruct = "IO::Uncompress::${AnyClass}" ; + no strict 'refs'; + my $AnyError = \${ "IO::Uncompress::${AnyClass}::${AnyClass}Error" }; + + for my $trans ( 0, 1 ) + { + for my $file ( 0, 1 ) + { + title "$AnyClass(Transparent => $trans, File=>$file) with $CompressClass" ; + my $string = "some text"; + + my $buffer ; + my $x = new $CompressClass(\$buffer) ; + ok $x, " create $CompressClass object" ; + ok $x->write($string), " write to object" ; + ok $x->close, " close ok" ; + + my $lex = new LexFile my $output; + my $input ; + + if ($file) { + writeFile($output, $buffer); + $input = $output; + } + else { + $input = \$buffer; + } + + my $unc = new $AnyConstruct $input, Transparent => $trans ; + + ok $unc, " Created $AnyClass object" + or print "# $$AnyError\n"; + my $uncomp ; + ok $unc->read($uncomp) > 0 + or print "# $$AnyError\n"; + my $y; + is $unc->read($y, 1), 0, " at eof" ; + ok $unc->eof(), " at eof" ; + #ok $unc->type eq $Type; + + is $uncomp, $string, " expected output" ; + } + } +} + +1; diff --git a/t/lib/compress/anyunc.pl b/t/lib/compress/anyunc.pl new file mode 100644 index 0000000000..2d5f166bac --- /dev/null +++ b/t/lib/compress/anyunc.pl @@ -0,0 +1,73 @@ + +use lib 't'; + +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 36 + $extra ; +} + +sub run +{ + my $CompressClass = identify(); + my $AnyClass = getClass(); + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + my $AnyConstruct = "IO::Uncompress::${AnyClass}" ; + no strict refs; + my $AnyError = \${ "IO::Uncompress::${AnyClass}::${AnyClass}Error" }; + + for my $trans ( 0, 1 ) + { + for my $file ( 0, 1 ) + { + title "$AnyClass(Transparent => $trans, File=>$file) with $CompressClass" ; + my $string = "some text"; + + my $buffer ; + my $x = new $CompressClass(\$buffer) ; + ok $x, " create $CompressClass object" ; + ok $x->write($string), " write to object" ; + ok $x->close, " close ok" ; + + my $lex = new LexFile my $output; + my $input ; + + if ($file) { + writeFile($output, $buffer); + $input = $output; + } + else { + $input = \$buffer; + } + + my $unc = new $AnyConstruct $input, Transparent => $trans ; + + ok $unc, " Created $AnyClass object" + or print "# $$AnyError\n"; + my $uncomp ; + ok $unc->read($uncomp) > 0 + or print "# $$AnyError\n"; + my $y; + is $unc->read($y, 1), 0, " at eof" ; + ok $unc->eof(), " at eof" ; + #ok $unc->type eq $Type; + + is $uncomp, $string, " expected output" ; + } + } +} + +1; diff --git a/ext/Compress/Zlib/t/19destroy.t b/t/lib/compress/destroy.pl index 0d4eb757de..6c14bec9ec 100644 --- a/ext/Compress/Zlib/t/19destroy.t +++ b/t/lib/compress/destroy.pl @@ -1,9 +1,3 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib"); - } -} use lib 't'; use strict; @@ -23,22 +17,20 @@ BEGIN $extra = 1 if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - plan tests => 23 + $extra ; + plan tests => 7 + $extra ; - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Compress::Deflate', qw($DeflateError)) ; - use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ; - use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; use_ok('IO::File') ; } - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate') +sub run { - title "Testing $CompressClass"; + my $CompressClass = identify(); + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + title "Testing $CompressClass"; { # Check that the class destructor will call close @@ -83,3 +75,4 @@ EOM } } +1; diff --git a/t/lib/compress/generic.pl b/t/lib/compress/generic.pl new file mode 100644 index 0000000000..2c0fead5a3 --- /dev/null +++ b/t/lib/compress/generic.pl @@ -0,0 +1,1418 @@ + +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + +our ($UncompressClass); +BEGIN +{ + # use Test::NoWarnings, if available + my $extra = 0 ; + + my $st = eval { require Test::NoWarnings ; import Test::NoWarnings; 1; }; + $extra = 1 + if $st ; + + + + plan(tests => 564 + $extra) ; +} + + + + +sub myGZreadFile +{ + my $filename = shift ; + my $init = shift ; + + + my $fil = new $UncompressClass $filename, + -Strict => 0, + -Append => 1 + ; + + my $data = ''; + $data = $init if defined $init ; + 1 while $fil->read($data) > 0; + + $fil->close ; + return $data ; +} + +sub run +{ + + my $CompressClass = identify(); + $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + { + + title "Testing $CompressClass Errors"; + + # Buffer not writable + eval qq[\$a = new $CompressClass(\\1) ;] ; + like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ; + + my($out, $gz); + $out = "" ; + eval qq[\$a = new $CompressClass ] . '$out ;' ; + like $@, mkEvalErr("^$CompressClass: output filename is undef or null string"); + + $out = undef ; + eval qq[\$a = new $CompressClass \$out ;] ; + like $@, mkEvalErr("^$CompressClass: output filename is undef or null string"); + + my $x ; + $gz = new $CompressClass(\$x); + + foreach my $name (qw(read readline getc)) + { + eval " \$gz->$name() " ; + like $@, mkEvalErr("^$name Not Available: File opened only for output"); + } + + eval ' $gz->write({})' ; + like $@, mkEvalErr("^${CompressClass}::write: not a scalar reference"); + #like $@, mkEvalErr("^${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref"); + + eval ' $gz->syswrite("abc", 1, 5)' ; + like $@, mkEvalErr("^${CompressClass}::write: offset outside string"); + + eval ' $gz->syswrite("abc", 1, -4)' ; + like $@, mkEvalErr("^${CompressClass}::write: offset outside string"); + } + + + { + title "Testing $UncompressClass Errors"; + + my $out = "" ; + eval qq[\$a = new $UncompressClass \$out ;] ; + like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string"); + $out = undef ; + eval qq[\$a = new $UncompressClass \$out ;] ; + like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string"); + + my $lex = new LexFile my $name ; + + ok ! -e $name, " $name does not exist"; + + eval qq[\$a = new $UncompressClass "$name" ;] ; + is $$UnError, "input file '$name' does not exist"; + + my $gc ; + my $guz = new $CompressClass(\$gc); + $guz->write("abc") ; + $guz->close(); + + my $x ; + my $gz = new $UncompressClass(\$gc); + + foreach my $name (qw(print printf write)) + { + eval " \$gz->$name() " ; + like $@, mkEvalErr("^$name Not Available: File opened only for intput"); + } + + } + + { + title "Testing $CompressClass and $UncompressClass"; + + { + my ($a, $x, @x) = ("","","") ; + + # Buffer not a scalar reference + eval qq[\$a = new $CompressClass \\\@x ;] ; + like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref"); + + # Buffer not a scalar reference + eval qq[\$a = new $UncompressClass \\\@x ;] ; + like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref"); + } + + foreach my $Type ( $CompressClass, $UncompressClass) + { + # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate + + my ($a, $x, @x) = ("","","") ; + + # Odd number of parameters + eval qq[\$a = new $Type "abc", -Output ] ; + like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1"); + + # Unknown parameter + eval qq[\$a = new $Type "anc", -Fred => 123 ;] ; + like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred"); + + # no in or out param + eval qq[\$a = new $Type ;] ; + like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter"); + + } + + + { + # write a very simple compressed file + # and read back + #======================================== + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + my $x ; + ok $x = new $CompressClass $name ; + + ok $x->write($hello), "write" ; + ok $x->flush(), "flush"; + ok $x->close, "close" ; + } + + { + my $uncomp; + ok my $x = new $UncompressClass $name, -Append => 1 ; + + my $len ; + 1 while ($len = $x->read($uncomp)) > 0 ; + + is $len, 0, "read returned 0" + or diag $$UnError ; + + ok $x->close ; + is $uncomp, $hello ; + } + } + + { + # write a very simple compressed file + # and read back + #======================================== + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + my $x ; + ok $x = new $CompressClass $name ; + + is $x->write(''), 0, "Write empty string is ok"; + is $x->write(undef), 0, "Write undef is ok"; + ok $x->write($hello), "Write ok" ; + ok $x->close, "Close ok" ; + } + + { + my $uncomp; + my $x = new $UncompressClass $name ; + ok $x, "creates $UncompressClass $name" ; + + my $data = ''; + $data .= $uncomp while $x->read($uncomp) > 0 ; + + ok $x->close, "close ok" ; + is $data, $hello, "expected output" ; + } + } + + + { + # write a very simple file with using an IO filehandle + # and read back + #======================================== + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + my $fh = new IO::File ">$name" ; + ok $fh, "opened file $name ok"; + my $x = new $CompressClass $fh ; + ok $x, " created $CompressClass $fh" ; + + is $x->fileno(), fileno($fh), "fileno match" ; + is $x->write(''), 0, "Write empty string is ok"; + is $x->write(undef), 0, "Write undef is ok"; + ok $x->write($hello), "write ok" ; + ok $x->flush(), "flush"; + ok $x->close,"close" ; + $fh->close() ; + } + + my $uncomp; + { + my $x ; + ok my $fh1 = new IO::File "<$name" ; + ok $x = new $UncompressClass $fh1, -Append => 1 ; + ok $x->fileno() == fileno $fh1 ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close ; + } + + ok $hello eq $uncomp ; + } + + { + # write a very simple file with using a glob filehandle + # and read back + #======================================== + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + title "$CompressClass: Input from typeglob filehandle"; + ok open FH, ">$name" ; + + my $x = new $CompressClass *FH ; + ok $x, " create $CompressClass" ; + + is $x->fileno(), fileno(*FH), " fileno" ; + is $x->write(''), 0, " Write empty string is ok"; + is $x->write(undef), 0, " Write undef is ok"; + ok $x->write($hello), " Write ok" ; + ok $x->flush(), " Flush"; + ok $x->close, " Close" ; + close FH; + } + + + my $uncomp; + { + title "$UncompressClass: Input from typeglob filehandle, append output"; + my $x ; + ok open FH, "<$name" ; + ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0 + or diag $$UnError ; + is $x->fileno(), fileno FH, " fileno ok" ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close, " close" ; + } + #exit; + + is $uncomp, $hello, " expected output" ; + } + + { + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + title "Outout to stdout via '-'" ; + + open(SAVEOUT, ">&STDOUT"); + my $dummy = fileno SAVEOUT; + open STDOUT, ">$name" ; + + my $x = new $CompressClass '-' ; + $x->write($hello); + $x->close; + + open(STDOUT, ">&SAVEOUT"); + + ok 1, " wrote to stdout" ; + } + + { + title "Input from stdin via filename '-'"; + + my $x ; + my $uncomp ; + my $stdinFileno = fileno(STDIN); + # open below doesn't return 1 sometines on XP + open(SAVEIN, "<&STDIN"); + ok open(STDIN, "<$name"), " redirect STDIN"; + my $dummy = fileno SAVEIN; + $x = new $UncompressClass '-', Append => 1; + ok $x, " created object" ; + is $x->fileno(), $stdinFileno, " fileno ok" ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close, " close" ; + open(STDIN, "<&SAVEIN"); + is $uncomp, $hello, " expected output" ; + } + } + + { + # write a compressed file to memory + # and read back + #======================================== + + my $name = "test.gz" ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + my $buffer ; + { + my $x ; + ok $x = new $CompressClass(\$buffer) ; + + ok ! defined $x->fileno() ; + is $x->write(''), 0, "Write empty string is ok"; + is $x->write(undef), 0, "Write undef is ok"; + ok $x->write($hello) ; + ok $x->flush(); + ok $x->close ; + + writeFile($name, $buffer) ; + #is anyUncompress(\$buffer), $hello, " any ok"; + } + + my $keep = $buffer ; + my $uncomp; + { + my $x ; + ok $x = new $UncompressClass(\$buffer, Append => 1) ; + + ok ! defined $x->fileno() ; + 1 while $x->read($uncomp) > 0 ; + + ok $x->close ; + } + + is $uncomp, $hello ; + ok $buffer eq $keep ; + } + + if ($CompressClass ne 'RawDeflate') + { + # write empty file + #======================================== + + my $buffer = ''; + { + my $x ; + ok $x = new $CompressClass(\$buffer) ; + ok $x->close ; + + } + + my $keep = $buffer ; + my $uncomp= ''; + { + my $x ; + ok $x = new $UncompressClass(\$buffer, Append => 1) ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close ; + } + + ok $uncomp eq '' ; + ok $buffer eq $keep ; + + } + + { + # write a larger file + #======================================== + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + my $input = '' ; + my $contents = '' ; + + { + my $x = new $CompressClass $name ; + ok $x, " created $CompressClass object"; + + ok $x->write($hello), " write ok" ; + $input .= $hello ; + ok $x->write("another line"), " write ok" ; + $input .= "another line" ; + # all characters + foreach (0 .. 255) + { $contents .= chr int $_ } + # generate a long random string + foreach (1 .. 5000) + { $contents .= chr int rand 256 } + + ok $x->write($contents), " write ok" ; + $input .= $contents ; + ok $x->close, " close ok" ; + } + + ok myGZreadFile($name) eq $input ; + my $x = readFile($name) ; + #print "length " . length($x) . " \n"; + } + + { + # embed a compressed file in another file + #================================ + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + my $header = "header info\n" ; + my $trailer = "trailer data\n" ; + + { + my $fh ; + ok $fh = new IO::File ">$name" ; + print $fh $header ; + my $x ; + ok $x = new $CompressClass $fh, + -AutoClose => 0 ; + + ok $x->binmode(); + ok $x->write($hello) ; + ok $x->close ; + print $fh $trailer ; + $fh->close() ; + } + + my ($fil, $uncomp) ; + my $fh1 ; + ok $fh1 = new IO::File "<$name" ; + # skip leading junk + my $line = <$fh1> ; + ok $line eq $header ; + + ok my $x = new $UncompressClass $fh1, Append => 1 ; + ok $x->binmode(); + 1 while $x->read($uncomp) > 0 ; + + ok $uncomp eq $hello ; + my $rest ; + read($fh1, $rest, 5000); + is $x->trailingData() . $rest, $trailer ; + #print "# [".$x->trailingData() . "][$rest]\n" ; + #exit; + + } + + { + # Write + # these tests come almost 100% from IO::String + + my $lex = new LexFile my $name ; + + my $io = $CompressClass->new($name); + + is $io->tell(), 0, " tell returns 0"; ; + + my $heisan = "Heisan\n"; + $io->print($heisan) ; + + ok ! $io->eof(), " ! eof"; + + is $io->tell(), length($heisan), " tell is " . length($heisan) ; + + $io->print("a", "b", "c"); + + { + local($\) = "\n"; + $io->print("d", "e"); + local($,) = ","; + $io->print("f", "g", "h"); + } + + { + local($\) ; + $io->print("D", "E"); + local($,) = "."; + $io->print("F", "G", "H"); + } + + my $foo = "1234567890"; + + is $io->syswrite($foo, length($foo)), length($foo), " syswrite ok" ; + if ( $[ < 5.6 ) + { is $io->syswrite($foo, length $foo), length $foo, " syswrite ok" } + else + { is $io->syswrite($foo), length $foo, " syswrite ok" } + is $io->syswrite($foo, length($foo)), length $foo, " syswrite ok"; + is $io->write($foo, length($foo), 5), 5, " write 5"; + is $io->write("xxx\n", 100, -1), 1, " write 1"; + + for (1..3) { + $io->printf("i(%d)", $_); + $io->printf("[%d]\n", $_); + } + $io->print("\n"); + + $io->close ; + + ok $io->eof(), " eof"; + + is myGZreadFile($name), "Heisan\nabcde\nf,g,h\nDEF.G.H" . + ("1234567890" x 3) . "67890\n" . + "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; + + + } + + { + # Read + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $lex = new LexFile my $name ; + + my %opts = () ; + my $iow = new $CompressClass $name, %opts; + $iow->print($str) ; + $iow->close ; + + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name ; + + ok ! $io->eof; + is $io->tell(), 0 ; + #my @lines = <$io>; + my @lines = $io->getlines(); + is @lines, 6 + or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; + is $lines[1], "of a paragraph\n" ; + is join('', @lines), $str ; + is $., 6; + is $io->tell(), length($str) ; + + ok $io->eof; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined($io->getline) || + defined($io->getc) || + $io->read($buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = $io->getline(); + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines(); + ok $io->eof; + ok @lines == 2 + or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# $lines[0]\n"; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (my $a = $io->getline()) { + push(@lines, $a); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 + or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + + eval { $io->read(1) } ; + like $@, mkErr("buffer parameter is read-only"); + + is $io->read($buf, 0), 0, "Requested 0 bytes" ; + + ok $io->read($buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok $io->sysread($buf, 3, 2) == 3 ; + ok $buf eq "Ths i" + or print "# [$buf]\n" ;; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + } + + { + # Read from non-compressed file + + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $lex = new LexFile my $name ; + + writeFile($name, $str); + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name, -Transparent => 1 ; + + ok defined $io; + ok ! $io->eof; + ok $io->tell() == 0 ; + my @lines = $io->getlines(); + ok @lines == 6; + ok $lines[1] eq "of a paragraph\n" ; + ok join('', @lines) eq $str ; + ok $. == 6; + ok $io->tell() == length($str) ; + + ok $io->eof; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined($io->getline) || + defined($io->getc) || + $io->read($buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = $io->getline; + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 2 + or print "# exected 2 lines, got " . scalar(@lines) . "\n"; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# [$lines[0]]\n" ; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (my $a = $io->getline) { + push(@lines, $a); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + ok $io->read($buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok $io->sysread($buf, 3, 2) == 3 ; + ok $buf eq "Ths i"; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + + } + + { + # Vary the length parameter in a read + + my $str = <<EOT; +x +x +This is an example +of a paragraph + + +and a single line. + +EOT + $str = $str x 100 ; + + + foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) + { + foreach my $trans (0, 1) + { + foreach my $append (0, 1) + { + title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; + + my $lex = new LexFile my $name ; + + if ($trans) { + writeFile($name, $str) ; + } + else { + my $iow = new $CompressClass $name; + $iow->print($str) ; + $iow->close ; + } + + + my $io = $UncompressClass->new($name, + -Append => $append, + -Transparent => $trans); + + my $buf; + + is $io->tell(), 0; + + if ($append) { + 1 while $io->read($buf, $bufsize) > 0; + } + else { + my $tmp ; + $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; + } + is length $buf, length $str; + ok $buf eq $str ; + ok ! $io->error() ; + ok $io->eof; + } + } + } + } + + foreach my $file (0, 1) + { + foreach my $trans (0, 1) + { + title "seek tests - file $file trans $trans" ; + + my $buffer ; + my $buff ; + my $lex = new LexFile my $name ; + + my $first = "beginning" ; + my $last = "the end" ; + + if ($trans) + { + $buffer = $first . "\x00" x 10 . $last; + writeFile($name, $buffer); + } + else + { + my $output ; + if ($file) + { + $output = $name ; + } + else + { + $output = \$buffer; + } + + my $iow = new $CompressClass $output ; + $iow->print($first) ; + ok $iow->seek(5, SEEK_CUR) ; + ok $iow->tell() == length($first)+5; + ok $iow->seek(0, SEEK_CUR) ; + ok $iow->tell() == length($first)+5; + ok $iow->seek(length($first)+10, SEEK_SET) ; + ok $iow->tell() == length($first)+10; + + $iow->print($last) ; + $iow->close ; + } + + my $input ; + if ($file) + { + $input = $name ; + } + else + { + $input = \$buffer ; + } + + ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ; + + my $io = $UncompressClass->new($input, Strict => 1); + ok $io->seek(length($first), SEEK_CUR) ; + ok ! $io->eof; + is $io->tell(), length($first); + + ok $io->read($buff, 5) ; + is $buff, "\x00" x 5 ; + is $io->tell(), length($first) + 5; + + ok $io->seek(0, SEEK_CUR) ; + my $here = $io->tell() ; + is $here, length($first)+5; + + ok $io->seek($here+5, SEEK_SET) ; + is $io->tell(), $here+5 ; + ok $io->read($buff, 100) ; + ok $buff eq $last ; + ok $io->eof; + } + } + + { + title "seek error cases" ; + + my $b ; + my $a = new $CompressClass(\$b) ; + + ok ! $a->error() ; + eval { $a->seek(-1, 10) ; }; + like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter"); + + eval { $a->seek(-1, SEEK_END) ; }; + like $@, mkErr("^${CompressClass}::seek: cannot seek backwards"); + + $a->write("fred"); + $a->close ; + + + my $u = new $UncompressClass(\$b) ; + + eval { $u->seek(-1, 10) ; }; + like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter"); + + eval { $u->seek(-1, SEEK_END) ; }; + like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed"); + + eval { $u->seek(-1, SEEK_CUR) ; }; + like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards"); + } + + foreach my $fb (qw(filename buffer filehandle)) + { + foreach my $append (0, 1) + { + { + title "$CompressClass -- Append $append, Output to $fb" ; + + my $lex = new LexFile my $name ; + + my $already = 'already'; + my $buffer = $already; + my $output; + + if ($fb eq 'buffer') + { $output = \$buffer } + elsif ($fb eq 'filename') + { + $output = $name ; + writeFile($name, $buffer); + } + elsif ($fb eq 'filehandle') + { + $output = new IO::File ">$name" ; + print $output $buffer; + } + + my $a = new $CompressClass($output, Append => $append) ; + ok $a, " Created $CompressClass"; + my $string = "appended"; + $a->write($string); + $a->close ; + + my $data ; + if ($fb eq 'buffer') + { + $data = $buffer; + } + else + { + $output->close + if $fb eq 'filehandle'; + $data = readFile($name); + } + + if ($append || $fb eq 'filehandle') + { + is substr($data, 0, length($already)), $already, " got prefix"; + substr($data, 0, length($already)) = ''; + } + + + my $uncomp; + my $x = new $UncompressClass(\$data, Append => 1) ; + ok $x, " created $UncompressClass"; + + my $len ; + 1 while ($len = $x->read($uncomp)) > 0 ; + + $x->close ; + is $uncomp, $string, ' Got uncompressed data' ; + + } + } + } + + foreach my $type (qw(buffer filename filehandle)) + { + title "$UncompressClass -- InputLength, read from $type"; + + my $compressed ; + my $string = "some data"; + my $c = new $CompressClass(\$compressed); + $c->write($string); + $c->close(); + + my $appended = "append"; + my $comp_len = length $compressed; + $compressed .= $appended; + + my $lex = new LexFile my $name ; + my $input ; + writeFile ($name, $compressed); + + if ($type eq 'buffer') + { + $input = \$compressed; + } + if ($type eq 'filename') + { + $input = $name; + } + elsif ($type eq 'filehandle') + { + my $fh = new IO::File "<$name" ; + ok $fh, "opened file $name ok"; + $input = $fh ; + } + + my $x = new $UncompressClass($input, InputLength => $comp_len) ; + ok $x, " created $UncompressClass"; + + my $len ; + my $output; + $len = $x->read($output, 100); + is $len, length($string); + is $output, $string; + + if ($type eq 'filehandle') + { + my $rest ; + $input->read($rest, 1000); + is $rest, $appended; + } + + + } + + foreach my $append (0, 1) + { + title "$UncompressClass -- Append $append" ; + + my $lex = new LexFile my $name ; + + my $string = "appended"; + my $compressed ; + my $c = new $CompressClass(\$compressed); + $c->write($string); + $c->close(); + + my $x = new $UncompressClass(\$compressed, Append => $append) ; + ok $x, " created $UncompressClass"; + + my $already = 'already'; + my $output = $already; + + my $len ; + $len = $x->read($output, 100); + is $len, length($string); + + $x->close ; + + if ($append) + { + is substr($output, 0, length($already)), $already, " got prefix"; + substr($output, 0, length($already)) = ''; + } + is $output, $string, ' Got uncompressed data' ; + } + + + foreach my $file (0, 1) + { + foreach my $trans (0, 1) + { + title "ungetc, File $file, Transparent $trans" ; + + my $lex = new LexFile my $name ; + + my $string = 'abcdeABCDE'; + my $b ; + if ($trans) + { + $b = $string ; + } + else + { + my $a = new $CompressClass(\$b) ; + $a->write($string); + $a->close ; + } + + my $from ; + if ($file) + { + writeFile($name, $b); + $from = $name ; + } + else + { + $from = \$b ; + } + + my $u = $UncompressClass->new($from, Transparent => 1) ; + my $first; + my $buff ; + + # do an ungetc before reading + $u->ungetc("X"); + $first = $u->getc(); + is $first, 'X'; + + $first = $u->getc(); + is $first, substr($string, 0,1); + $u->ungetc($first); + $first = $u->getc(); + is $first, substr($string, 0,1); + $u->ungetc($first); + + is $u->read($buff, 5), 5 ; + is $buff, substr($string, 0, 5); + + $u->ungetc($buff) ; + is $u->read($buff, length($string)), length($string) ; + is $buff, $string; + + is $u->read($buff, 1), 0; + ok $u->eof() ; + + my $extra = 'extra'; + $u->ungetc($extra); + ok ! $u->eof(); + is $u->read($buff), length($extra) ; + is $buff, $extra; + + is $u->read($buff, 1), 0; + ok $u->eof() ; + + $u->close(); + + } + } + + + { + title "write tests - invalid data" ; + + #my $lex = new LexFile my $name1 ; + my($Answer); + + #ok ! -e $name1, " File $name1 does not exist"; + + my @data = ( + [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], + [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], + [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], + [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ], + [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ], + [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ], + #[ "not readable", 'xx' ], + # same filehandle twice, 'xx' + ) ; + + foreach my $data (@data) + { + my ($send, $get) = @$data ; + title "${CompressClass}::write( $send )"; + my($copy); + eval "\$copy = $send"; + my $x = new $CompressClass(\$Answer); + ok $x, " Created $CompressClass object"; + eval { $x->write($copy) } ; + #like $@, "/^$get/", " error - $get"; + like $@, "/not a scalar reference /", " error - not a scalar reference"; + } + + # @data = ( + # [ '[ $name1 ]', "input file '$name1' does not exist" ], + # #[ "not readable", 'xx' ], + # # same filehandle twice, 'xx' + # ) ; + # + # foreach my $data (@data) + # { + # my ($send, $get) = @$data ; + # title "${CompressClass}::write( $send )"; + # my $copy; + # eval "\$copy = $send"; + # my $x = new $CompressClass(\$Answer); + # ok $x, " Created $CompressClass object"; + # ok ! $x->write($copy), " write fails" ; + # like $$Error, "/^$get/", " error - $get"; + # } + + #exit; + + } + + + # sub deepCopy + # { + # if (! ref $_[0] || ref $_[0] eq 'SCALAR') + # { + # return $_[0] ; + # } + # + # if (ref $_[0] eq 'ARRAY') + # { + # my @a ; + # for my $x ( @{ $_[0] }) + # { + # push @a, deepCopy($x); + # } + # + # return \@a ; + # } + # + # croak "bad! $_[0]"; + # + # } + # + # sub deepSubst + # { + # #my $data = shift ; + # my $from = $_[1] ; + # my $to = $_[2] ; + # + # if (! ref $_[0]) + # { + # $_[0] = $to + # if $_[0] eq $from ; + # return ; + # + # } + # + # if (ref $_[0] eq 'SCALAR') + # { + # $_[0] = \$to + # if defined ${ $_[0] } && ${ $_[0] } eq $from ; + # return ; + # + # } + # + # if (ref $_[0] eq 'ARRAY') + # { + # for my $x ( @{ $_[0] }) + # { + # deepSubst($x, $from, $to); + # } + # return ; + # } + # #croak "bad! $_[0]"; + # } + + # { + # title "More write tests" ; + # + # my $file1 = "file1" ; + # my $file2 = "file2" ; + # my $file3 = "file3" ; + # my $lex = new LexFile $file1, $file2, $file3 ; + # + # writeFile($file1, "F1"); + # writeFile($file2, "F2"); + # writeFile($file3, "F3"); + # + # my @data = ( + # [ '""', "" ], + # [ 'undef', "" ], + # [ '"abcd"', "abcd" ], + # + # [ '\""', "" ], + # [ '\undef', "" ], + # [ '\"abcd"', "abcd" ], + # + # [ '[]', "" ], + # [ '[[]]', "" ], + # [ '[[[]]]', "" ], + # [ '[\""]', "" ], + # [ '[\undef]', "" ], + # [ '[\"abcd"]', "abcd" ], + # [ '[\"ab", \"cd"]', "abcd" ], + # [ '[[\"ab"], [\"cd"]]', "abcd" ], + # + # [ '$file1', $file1 ], + # [ '$fh2', "F2" ], + # [ '[$file1, \"abc"]', "F1abc"], + # [ '[\"a", $file1, \"bc"]', "aF1bc"], + # [ '[\"a", $fh1, \"bc"]', "aF1bc"], + # [ '[\"a", $fh1, \"bc", $file2]', "aF1bcF2"], + # [ '[\"a", $fh1, \"bc", $file2, $fh3]', "aF1bcF2F3"], + # ) ; + # + # + # foreach my $data (@data) + # { + # my ($send, $get) = @$data ; + # + # my $fh1 = new IO::File "< $file1" ; + # my $fh2 = new IO::File "< $file2" ; + # my $fh3 = new IO::File "< $file3" ; + # + # title "${CompressClass}::write( $send )"; + # my $copy; + # eval "\$copy = $send"; + # my $Answer ; + # my $x = new $CompressClass(\$Answer); + # ok $x, " Created $CompressClass object"; + # my $len = length $get; + # is $x->write($copy), length($get), " write $len bytes"; + # ok $x->close(), " close ok" ; + # + # is myGZreadFile(\$Answer), $get, " got expected output" ; + # cmp_ok $$Error, '==', 0, " no error"; + # + # + # } + # + # } + } + +} + +1; + + + + diff --git a/t/lib/compress/merge.pl b/t/lib/compress/merge.pl new file mode 100644 index 0000000000..7def4393f5 --- /dev/null +++ b/t/lib/compress/merge.pl @@ -0,0 +1,338 @@ +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +use Compress::Zlib 2 ; + +BEGIN +{ + plan(skip_all => "Merge needs Zlib 1.2.1 or better - you have Zlib " + . Compress::Zlib::zlib_version()) + if ZLIB_VERNUM() < 0x1210 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 166 + $extra ; + +} + + +sub run +{ + + my $CompressClass = identify(); + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + + + + # Check zlib_version and ZLIB_VERSION are the same. + is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + + # Tests + # destination is a file that doesn't exist -- should work ok unless AnyDeflate + # destination isn't compressed at all + # destination is compressed but wrong format + # destination is corrupt - error messages should be correct + # use apend mode with old zlib - check that this is trapped + # destination is not seekable, readable, writable - test for filename & handle + + { + title "Misc error cases"; + + eval { new Compress::Zlib::InflateScan Bufsize => 0} ; + like $@, mkErr("^Compress::Zlib::InflateScan::new: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0"; + + eval { Compress::Zlib::inflateScanStream::createDeflateStream(undef, Bufsize => 0) } ; + like $@, mkErr("^Compress::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0"; + + } + + # output file/handle not writable + { + + foreach my $to_file (0,1) + { + if ($to_file) + { title "$CompressClass - Merge to filename that isn't writable" } + else + { title "$CompressClass - Merge to filehandle that isn't writable" } + + my $lex = new LexFile my $out_file ; + + # create empty file + open F, ">$out_file" ; print F "x"; close F; + ok -e $out_file, " file exists" ; + ok !-z $out_file, " and is not empty" ; + + # make unwritable + is chmod(0444, $out_file), 1, " chmod worked" ; + ok -e $out_file, " still exists after chmod" ; + + SKIP: + { + skip "Cannot create non-writable file", 3 + if -w $out_file ; + + ok ! -w $out_file, " chmod made file unwritable" ; + + my $dest ; + if ($to_file) + { $dest = $out_file } + else + { $dest = new IO::File "<$out_file" } + + my $gz = $CompressClass->new($dest, Merge => 1) ; + + ok ! $gz, " Did not create $CompressClass object"; + + { + if ($to_file) { + is $$Error, "Output file '$out_file' is not writable", + " Got non-writable filename message" ; + } + else { + is $$Error, "Output filehandle is not writable", + " Got non-writable filehandle message" ; + } + } + } + + chmod 0777, $out_file ; + } + } + + # output is not compressed at all + { + + my $lex = new LexFile my $out_file ; + + foreach my $to_file ( qw(buffer file handle ) ) + { + title "$CompressClass to $to_file, content is not compressed"; + + my $content = "abc" x 300 ; + my $buffer ; + my $disp_content = defined $content ? $content : '<undef>' ; + my $str_content = defined $content ? $content : '' ; + + if ($to_file eq 'buffer') + { + $buffer = \$content ; + } + else + { + writeFile($out_file, $content); + + if ($to_file eq 'handle') + { + $buffer = new IO::File "+<$out_file" + or die "# Cannot open $out_file: $!"; + } + else + { $buffer = $out_file } + } + + ok ! $CompressClass->new($buffer, Merge => 1), " constructor fails"; + { + like $$Error, '/Cannot create InflateScan object: (Header Error|unexpected end of file)/', " got Bad Magic" ; + } + + } + } + + # output is empty + { + + my $lex = new LexFile my $out_file ; + + foreach my $to_file ( qw(buffer file handle ) ) + { + title "$CompressClass to $to_file, content is empty"; + + my $content = ''; + my $buffer ; + my $dest ; + + if ($to_file eq 'buffer') + { + $dest = $buffer = \$content ; + } + else + { + writeFile($out_file, $content); + $dest = $out_file; + + if ($to_file eq 'handle') + { + $buffer = new IO::File "+<$out_file" + or die "# Cannot open $out_file: $!"; + } + else + { $buffer = $out_file } + } + + ok my $gz = $CompressClass->new($buffer, Merge => 1, AutoClose => 1), " constructor passes" + or diag $$Error; + + $gz->write("FGHI"); + $gz->close(); + + #hexDump($buffer); + my $out = anyUncompress($dest); + + is $out, "FGHI", ' Merge OK'; + } + } + + { + title "$CompressClass - Merge to file that doesn't exist"; + + my $lex = new LexFile my $out_file ; + + ok ! -e $out_file, " Destination file, '$out_file', does not exist"; + + ok my $gz1 = $CompressClass->new($out_file, Merge => 1) + or die "# $CompressClass->new failed: $$Error\n"; + #hexDump($buffer); + $gz1->write("FGHI"); + $gz1->close(); + + #hexDump($buffer); + my $out = anyUncompress($out_file); + + is $out, "FGHI", ' Merged OK'; + } + + { + + my $lex = new LexFile my $out_file ; + + foreach my $to_file ( qw( buffer file handle ) ) + { + foreach my $content (undef, '', 'x', 'abcde') + { + #next if ! defined $content && $to_file; + + my $buffer ; + my $disp_content = defined $content ? $content : '<undef>' ; + my $str_content = defined $content ? $content : '' ; + + if ($to_file eq 'buffer') + { + my $x ; + $buffer = \$x ; + title "$CompressClass to Buffer, content is '$disp_content'"; + } + else + { + $buffer = $out_file ; + if ($to_file eq 'handle') + { + title "$CompressClass to Filehandle, content is '$disp_content'"; + } + else + { + title "$CompressClass to File, content is '$disp_content'"; + } + } + + my $gz = $CompressClass->new($buffer); + my $len = defined $content ? length($content) : 0 ; + is $gz->write($content), $len, " write ok"; + ok $gz->close(), " close ok"; + + #hexDump($buffer); + is anyUncompress($buffer), $str_content, ' Destination is ok'; + + #if ($corruption) + #{ + # next if $TopTypes eq 'RawDeflate' && $content eq ''; + # + #} + + my $dest = $buffer ; + if ($to_file eq 'handle') + { + $dest = new IO::File "+<$buffer" ; + } + + my $gz1 = $CompressClass->new($dest, Merge => 1, AutoClose => 1) + or die "## Error is $$Error\n"; + + #print "YYY\n"; + #hexDump($buffer); + #print "XXX\n"; + is $gz1->write("FGHI"), 4, " write returned 4"; + ok $gz1->close(), " close ok"; + + #hexDump($buffer); + my $out = anyUncompress($buffer); + + is $out, $str_content . "FGHI", ' Merged OK'; + #exit; + } + } + + } + + + + { + my $Func = getTopFuncRef($CompressClass); + my $TopType = getTopFuncName($CompressClass); + + my $buffer ; + + my $lex = new LexFile my $out_file ; + + foreach my $to_file (0, 1) + { + foreach my $content (undef, '', 'x', 'abcde') + { + my $disp_content = defined $content ? $content : '<undef>' ; + my $str_content = defined $content ? $content : '' ; + my $buffer ; + if ($to_file) + { + $buffer = $out_file ; + title "$TopType to File, content is '$disp_content'"; + } + else + { + my $x = ''; + $buffer = \$x ; + title "$TopType to Buffer, content is '$disp_content'"; + } + + + ok $Func->(\$content, $buffer), " Compress content"; + #hexDump($buffer); + is anyUncompress($buffer), $str_content, ' Destination is ok'; + + + ok $Func->(\"FGHI", $buffer, Merge => 1), " Merge content"; + + #hexDump($buffer); + my $out = anyUncompress($buffer); + + is $out, $str_content . "FGHI", ' Merged OK'; + } + } + + } + +} + + +1; diff --git a/t/lib/compress/multi.pl b/t/lib/compress/multi.pl new file mode 100644 index 0000000000..8d96e9c207 --- /dev/null +++ b/t/lib/compress/multi.pl @@ -0,0 +1,142 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 190 + $extra ; + + use_ok('IO::Uncompress::AnyUncompress', qw($AnyUncompressError)) ; + +} + +sub run +{ + + my $CompressClass = identify(); + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + + + + my @buffers ; + push @buffers, <<EOM ; +hello world +this is a test +some more stuff on this line +ad finally... +EOM + + push @buffers, <<EOM ; +some more stuff +EOM + + push @buffers, <<EOM ; +even more stuff +EOM + + { + my $cc ; + my $gz ; + my $hsize ; + my %headers = () ; + + + foreach my $fb ( qw( file filehandle buffer ) ) + { + + foreach my $i (1 .. @buffers) { + + title "Testing $CompressClass with $i streams to $fb"; + + my @buffs = @buffers[0..$i -1] ; + + if ($CompressClass eq 'IO::Compress::Gzip') { + %headers = ( + Strict => 0, + Comment => "this is a comment", + ExtraField => "some extra", + HeaderCRC => 1); + + } + + my $lex = new LexFile my $name ; + my $output ; + if ($fb eq 'buffer') + { + my $compressed = ''; + $output = \$compressed; + } + elsif ($fb eq 'filehandle') + { + $output = new IO::File ">$name" ; + } + else + { + $output = $name ; + } + + my $x = new $CompressClass($output, AutoClose => 1, %headers); + isa_ok $x, $CompressClass, ' $x' ; + + foreach my $buffer (@buffs) { + ok $x->write($buffer), " Write OK" ; + # this will add an extra "empty" stream + ok $x->newStream(), " newStream OK" ; + } + ok $x->close, " Close ok" ; + + #hexDump($compressed) ; + + foreach my $unc ($UncompressClass, 'IO::Uncompress::AnyUncompress') { + title " Testing $CompressClass with $unc and $i streams, from $fb"; + $cc = $output ; + if ($fb eq 'filehandle') + { + $cc = new IO::File "<$name" ; + } + my $gz = new $unc($cc, + Strict => 0, + AutoClose => 1, + Append => 1, + MultiStream => 1, + Transparent => 0); + isa_ok $gz, $UncompressClass, ' $gz' ; + + my $un = ''; + 1 while $gz->read($un) > 0 ; + #print "[[$un]]\n" while $gz->read($un) > 0 ; + ok ! $gz->error(), " ! error()" + or diag "Error is " . $gz->error() ; + ok $gz->eof(), " eof()"; + ok $gz->close(), " close() ok" + or diag "errno $!\n" ; + + is $gz->streamCount(), $i +1, " streamCount ok" + or diag "Stream count is " . $gz->streamCount(); + ok $un eq join('', @buffs), " expected output" ; + + } + } + } + } +} + + +# corrupt one of the streams - all previous should be ok +# trailing stuff +# need a way to skip to the start of the next stream. +# check that "tell" works ok + +1; diff --git a/t/lib/compress/newtied.pl b/t/lib/compress/newtied.pl new file mode 100644 index 0000000000..e31019691f --- /dev/null +++ b/t/lib/compress/newtied.pl @@ -0,0 +1,374 @@ +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +our ($BadPerl, $UncompressClass); + +BEGIN +{ + plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" ) + if $] < 5.006 ; + + my $tests ; + + $BadPerl = ($] >= 5.006 and $] <= 5.008) ; + + if ($BadPerl) { + $tests = 78 ; + } + else { + $tests = 84 ; + } + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => $tests + $extra ; + +} + + +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + + + +sub myGZreadFile +{ + my $filename = shift ; + my $init = shift ; + + + my $fil = new $UncompressClass $filename, + -Strict => 1, + -Append => 1 + ; + + my $data ; + $data = $init if defined $init ; + 1 while $fil->read($data) > 0; + + $fil->close ; + return $data ; +} + + +sub run +{ + + my $CompressClass = identify(); + $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + { + title "Testing $CompressClass and $UncompressClass"; + + + + { + # Write + # these tests come almost 100% from IO::String + + my $lex = new LexFile my $name ; + + my $io = $CompressClass->new($name); + + is tell($io), 0 ; + is $io->tell(), 0 ; + + my $heisan = "Heisan\n"; + print $io $heisan ; + + ok ! eof($io); + ok ! $io->eof(); + + is tell($io), length($heisan) ; + is $io->tell(), length($heisan) ; + + $io->print("a", "b", "c"); + + { + local($\) = "\n"; + print $io "d", "e"; + local($,) = ","; + print $io "f", "g", "h"; + } + + my $foo = "1234567890"; + + ok syswrite($io, $foo, length($foo)) == length($foo) ; + if ( $[ < 5.6 ) + { is $io->syswrite($foo, length $foo), length $foo } + else + { is $io->syswrite($foo), length $foo } + ok $io->syswrite($foo, length($foo)) == length $foo; + ok $io->write($foo, length($foo), 5) == 5; + ok $io->write("xxx\n", 100, -1) == 1; + + for (1..3) { + printf $io "i(%d)", $_; + $io->printf("[%d]\n", $_); + } + select $io; + print "\n"; + select STDOUT; + + close $io ; + + ok eof($io); + ok $io->eof(); + + is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . + ("1234567890" x 3) . "67890\n" . + "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; + + + } + + { + # Read + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $lex = new LexFile my $name ; + + my $iow = new $CompressClass $name ; + print $iow $str ; + close $iow; + + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name ; + + ok ! $io->eof; + ok ! eof $io; + is $io->tell(), 0 ; + is tell($io), 0 ; + my @lines = <$io>; + is @lines, 6 + or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; + is $lines[1], "of a paragraph\n" ; + is join('', @lines), $str ; + is $., 6; + #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ; + is $io->tell(), length($str) ; + is tell($io), length($str) ; + + ok $io->eof; + ok eof $io; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined(<$io>) || + defined($io->getc) || + read($io, $buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = <$io>; + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = <$io>; + ok $io->eof; + ok @lines == 2 + or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# $lines[0]\n"; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (<$io>) { + push(@lines, $_); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 + or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + ok $io, "opened ok" ; + + #eval { read($io, $buf, -1); } ; + #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ; + + #eval { read($io, 1) } ; + #like $@, mkErr("buffer parameter is read-only"); + + is read($io, $buf, 0), 0, "Requested 0 bytes" ; + + ok read($io, $buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok sysread($io, $buf, 3, 2) == 3 ; + ok $buf eq "Ths i" + or print "# [$buf]\n" ;; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + } + + + + { + title "seek tests" ; + + my $lex = new LexFile my $name ; + + my $first = "beginning" ; + my $last = "the end" ; + my $iow = new $CompressClass $name ; + print $iow $first ; + ok seek $iow, 10, SEEK_CUR ; + is tell($iow), length($first)+10; + ok $iow->seek(0, SEEK_CUR) ; + is tell($iow), length($first)+10; + print $iow $last ; + close $iow; + + my $io = $UncompressClass->new($name); + ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ; + + $io = $UncompressClass->new($name); + ok seek $io, length($first)+10, SEEK_CUR ; + ok ! $io->eof; + is tell($io), length($first)+10; + ok seek $io, 0, SEEK_CUR ; + is tell($io), length($first)+10; + my $buff ; + ok read $io, $buff, 100 ; + ok $buff eq $last ; + ok $io->eof; + } + + if (! $BadPerl) + { + # seek error cases + my $b ; + my $a = new $CompressClass(\$b) ; + + ok ! $a->error() ; + eval { seek($a, -1, 10) ; }; + like $@, mkErr("seek: unknown value, 10, for whence parameter"); + + eval { seek($a, -1, SEEK_END) ; }; + like $@, mkErr("cannot seek backwards"); + + print $a "fred"; + close $a ; + + + my $u = new $UncompressClass(\$b) ; + + eval { seek($u, -1, 10) ; }; + like $@, mkErr("seek: unknown value, 10, for whence parameter"); + + eval { seek($u, -1, SEEK_END) ; }; + like $@, mkErr("seek: SEEK_END not allowed"); + + eval { seek($u, -1, SEEK_CUR) ; }; + like $@, mkErr("cannot seek backwards"); + } + + { + title 'fileno' ; + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + my $fh ; + ok $fh = new IO::File ">$name" ; + my $x ; + ok $x = new $CompressClass $fh ; + + ok $x->fileno() == fileno($fh) ; + ok $x->fileno() == fileno($x) ; + ok $x->write($hello) ; + ok $x->close ; + $fh->close() ; + } + + my $uncomp; + { + my $x ; + ok my $fh1 = new IO::File "<$name" ; + ok $x = new $UncompressClass $fh1, -Append => 1 ; + ok $x->fileno() == fileno $fh1 ; + ok $x->fileno() == fileno $x ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close ; + } + + ok $hello eq $uncomp ; + } + } +} + +1; diff --git a/t/lib/compress/oneshot.pl b/t/lib/compress/oneshot.pl new file mode 100644 index 0000000000..048006c049 --- /dev/null +++ b/t/lib/compress/oneshot.pl @@ -0,0 +1,1431 @@ +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +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 => 944 + $extra ; + + use_ok('IO::Uncompress::AnyInflate', qw(anyinflate $AnyInflateError)) ; + +} + +sub run +{ + + my $CompressClass = identify(); + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + my $TopFuncName = getTopFuncName($CompressClass); + + + + foreach my $bit ($CompressClass, $UncompressClass, + 'IO::Uncompress::AnyInflate', + ) + { + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + title "Testing $TopType Error Cases"; + + my $a; + my $x ; + + eval { $a = $Func->(\$a => \$x, Fred => 1) ;} ; + like $@, mkErr("^$TopType: unknown key value\\(s\\) Fred"), ' Illegal Parameters'; + + eval { $a = $Func->() ;} ; + like $@, mkErr("^$TopType: expected at least 1 parameters"), ' No Parameters'; + + eval { $a = $Func->(\$x, \1) ;} ; + like $$Error, "/^$TopType: output buffer is read-only/", ' Output is read-only' ; + + my $in ; + eval { $a = $Func->($in, \$x) ;} ; + like $@, mkErr("^$TopType: input filename is undef or null string"), + ' Input filename undef' ; + + $in = ''; + eval { $a = $Func->($in, \$x) ;} ; + like $@, mkErr("^$TopType: input filename is undef or null string"), + ' Input filename empty' ; + + { + my $lex1 = new LexFile my $in ; + writeFile($in, "abc"); + my $out = $in ; + eval { $a = $Func->($in, $out) ;} ; + like $@, mkErr("^$TopType: input and output filename are identical"), + ' Input and Output filename are the same'; + } + + eval { $a = $Func->(\$in, \$in) ;} ; + like $@, mkErr("^$TopType: input and output buffer are identical"), + ' Input and Output buffer are the same'; + + my $lex = new LexFile my $out_file ; + open OUT, ">$out_file" ; + eval { $a = $Func->(\*OUT, \*OUT) ;} ; + like $@, mkErr("^$TopType: input and output handle are identical"), + ' Input and Output handle are the same'; + + close OUT; + is -s $out_file, 0, " File zero length" ; + { + my %x = () ; + my $object = bless \%x, "someClass" ; + + # Buffer not a scalar reference + #eval { $a = $Func->(\$x, \%x) ;} ; + eval { $a = $Func->(\$x, $object) ;} ; + like $@, mkErr("^$TopType: illegal output parameter"), + ' Bad Output Param'; + + # Buffer not a scalar reference + eval { $a = $Func->(\$x, \%x) ;} ; + like $@, mkErr("^$TopType: illegal output parameter"), + ' Bad Output Param'; + + + eval { $a = $Func->(\%x, \$x) ;} ; + like $@, mkErr("^$TopType: illegal input parameter"), + ' Bad Input Param'; + + #eval { $a = $Func->(\%x, \$x) ;} ; + eval { $a = $Func->($object, \$x) ;} ; + like $@, mkErr("^$TopType: illegal input parameter"), + ' Bad Input Param'; + } + + my $filename = 'abc.def'; + ok ! -e $filename, " input file '$filename' does not exist"; + $a = $Func->($filename, \$x) ; + is $a, undef, " $TopType returned undef"; + like $$Error, "/^input file '$filename' does not exist\$/", " input File '$filename' does not exist"; + + $filename = '/tmp/abd/abc.def'; + ok ! -e $filename, " output File '$filename' does not exist"; + $a = $Func->(\$x, $filename) ; + is $a, undef, " $TopType returned undef"; + like $$Error, ("/^(cannot open file '$filename'|input file '$filename' does not exist):/"), " output File '$filename' does not exist"; + + eval { $a = $Func->(\$x, '<abc>') } ; + like $$Error, "/Need input fileglob for outout fileglob/", + ' Output fileglob with no input fileglob'; + is $a, undef, " $TopType returned undef"; + + $a = $Func->('<abc)>', '<abc>') ; + is $a, undef, " $TopType returned undef"; + like $$Error, "/Unmatched \\) in input fileglob/", + " Unmatched ) in input fileglob"; + } + + foreach my $bit ($UncompressClass, + 'IO::Uncompress::AnyInflate', + ) + { + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $data = "mary had a little lamb" ; + my $keep = $data ; + + for my $trans ( 0, 1) + { + title "Non-compressed data with $TopType, Transparent => $trans "; + my $a; + my $x ; + my $out = '' ; + + $a = $Func->(\$data, \$out, Transparent => $trans) ; + + is $data, $keep, " Input buffer not changed" ; + + if ($trans) + { + ok $a, " $TopType returned true" ; + is $out, $data, " got expected output" ; + ok ! $$Error, " no error [$$Error]" ; + } + else + { + ok ! $a, " $TopType returned false" ; + #like $$Error, '/xxx/', " error" ; + ok $$Error, " error is '$$Error'" ; + } + } + } + + foreach my $bit ($CompressClass + ) + { + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + my $TopTypeInverse = getInverse($bit); + my $FuncInverse = getTopFuncRef($TopTypeInverse); + my $ErrorInverse = getErrorRef($TopTypeInverse); + + title "$TopTypeInverse - corrupt data"; + + my $data = "abcd" x 100 ; + my $out; + + ok $Func->(\$data, \$out), " $TopType ok"; + + # corrupt the compressed data + #substr($out, -10, 10) = "x" x 10 ; + substr($out, int(length($out)/3), 10) = 'abcdeabcde'; + + my $result; + ok ! $FuncInverse->(\$out => \$result, Transparent => 0), " $TopTypeInverse ok"; + ok $$ErrorInverse, " Got error '$$ErrorInverse'" ; + + #is $result, $data, " data ok"; + + ok ! anyinflate(\$out => \$result, Transparent => 0), " anyinflate ok"; + ok $AnyInflateError, " Got error '$AnyInflateError'" ; + } + + + foreach my $bit ($CompressClass + ) + { + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + my $TopTypeInverse = getInverse($bit); + my $FuncInverse = getTopFuncRef($TopTypeInverse); + + for my $append ( 1, 0 ) + { + my $already = ''; + $already = 'abcde' if $append ; + + for my $buffer ( undef, '', "abcde" ) + { + + my $disp_content = defined $buffer ? $buffer : '<undef>' ; + + my $keep = $buffer; + my $out_file = "abcde.out"; + my $in_file = "abcde.in"; + + { + title "$TopType - From Buff to Buff content '$disp_content' Append $append" ; + + my $output = $already; + ok &$Func(\$buffer, \$output, Append => $append), ' Compressed ok' ; + + is $keep, $buffer, " Input buffer not changed" ; + my $got = anyUncompress(\$output, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + + } + + { + title "$TopType - From Buff to Array Ref content '$disp_content' Append $append" ; + + my @output = ('first') ; + ok &$Func(\$buffer, \@output, Append => $append), ' Compressed ok' ; + + is $output[0], 'first', " Array[0] unchanged"; + is $keep, $buffer, " Input buffer not changed" ; + my $got = anyUncompress($output[1]); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + } + + { + title "$TopType - From Array Ref to Array Ref content '$disp_content' Append $append" ; + + my $lex = new LexFile my $in_file ; + writeFile($in_file, $buffer); + my @output = ('first') ; + my @input = ($in_file); + ok &$Func(\@input, \@output, Append => $append), ' Compressed ok' ; + + is $output[0], 'first', " Array[0] unchanged"; + my $got = anyUncompress($output[1]); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + } + + { + title "$TopType - From Buff to Filename content '$disp_content' Append $append" ; + + my $lex = new LexFile my $out_file ; + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + + ok &$Func(\$buffer, $out_file, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + } + + { + title "$TopType - From Buff to Handle content '$disp_content' Append $append" ; + + my $lex = new LexFile my $out_file ; + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + my $of = new IO::File ">>$out_file" ; + ok $of, " Created output filehandle" ; + + ok &$Func(\$buffer, $of, AutoClose => 1, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + } + + + { + title "$TopType - From Filename to Filename content '$disp_content' Append $append" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + writeFile($in_file, $buffer); + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + + ok &$Func($in_file => $out_file, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + + } + + { + title "$TopType - From Filename to Handle content '$disp_content' Append $append" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + writeFile($in_file, $buffer); + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + my $out = new IO::File ">>$out_file" ; + + ok &$Func($in_file, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + + } + + { + title "$TopType - From Filename to Buffer content '$disp_content' Append $append" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + writeFile($in_file, $buffer); + + my $out = $already; + + ok &$Func($in_file => \$out, Append => $append), ' Compressed ok' ; + + my $got = anyUncompress(\$out, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + + } + + { + title "$TopType - From Handle to Filename content '$disp_content' Append $append" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + writeFile($in_file, $buffer); + my $in = new IO::File "<$in_file" ; + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + + ok &$Func($in, $out_file, Append => $append), ' Compressed ok' + or diag "error is $$Error" ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $buffer, $got, " Uncompressed matches original"; + + } + + { + title "$TopType - From Handle to Handle content '$disp_content' Append $append" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + writeFile($in_file, $buffer); + my $in = new IO::File "<$in_file" ; + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + my $out = new IO::File ">>$out_file" ; + + ok &$Func($in, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $buffer, $got, " Uncompressed matches original"; + + } + + { + title "$TopType - From Handle to Buffer content '$disp_content' Append $append" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + writeFile($in_file, $buffer); + my $in = new IO::File "<$in_file" ; + + my $out = $already ; + + ok &$Func($in, \$out, Append => $append), ' Compressed ok' ; + + my $got = anyUncompress(\$out, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $buffer, $got, " Uncompressed matches original"; + + } + + { + title "$TopType - From stdin (via '-') to Buffer content '$disp_content' Append $append" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + writeFile($in_file, $buffer); + + open(SAVEIN, "<&STDIN"); + my $dummy = fileno SAVEIN ; + ok open(STDIN, "<$in_file"), " redirect STDIN"; + + my $out = $already; + + ok &$Func('-', \$out, Append => $append), ' Compressed ok' + or diag $$Error ; + + open(STDIN, "<&SAVEIN"); + + my $got = anyUncompress(\$out, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $buffer, $got, " Uncompressed matches original"; + + } + + } + } + } + + foreach my $bit ($CompressClass) + { + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $TopTypeInverse = getInverse($bit); + my $FuncInverse = getTopFuncRef($TopTypeInverse); + + my $lex = new LexFile(my $file1, my $file2) ; + + writeFile($file1, "data1"); + writeFile($file2, "data2"); + my $of = new IO::File "<$file1" ; + ok $of, " Created output filehandle" ; + + #my @input = ( undef, "", $file2, \undef, \'', \"abcde", $of) ; + #my @expected = ("", "", $file2, "", "", "abcde", "data1"); + #my @uexpected = ("", "", "data2", "", "", "abcde", "data1"); + #my @input = ( $file2, \"abcde", $of) ; + #my @expected = ( $file2, "abcde", "data1"); + #my @uexpected = ("data2", "abcde", "data1"); + + my @input = ( $file1, $file2) ; + #my @expected = ( $file1, $file2); + my @expected = ("data1", "data2"); + my @uexpected = ("data1", "data2"); + + my @keep = @input ; + + { + title "$TopType - From Array Ref to Array Ref" ; + + my @output = ('first') ; + ok &$Func(\@input, \@output, AutoClose => 0), ' Compressed ok' ; + + is $output[0], 'first', " Array[0] unchanged"; + + is_deeply \@input, \@keep, " Input array not changed" ; + my @got = shift @output; + foreach (@output) { push @got, anyUncompress($_) } + + is_deeply \@got, ['first', @expected], " Got Expected uncompressed data"; + + } + + foreach my $ms (1, 0) + { + { + title "$TopType - From Array Ref to Buffer, MultiStream $ms" ; + + # rewind the filehandle + $of->open("<$file1") ; + + my $output ; + ok &$Func(\@input, \$output, MultiStream => $ms, AutoClose => 0), ' Compressed ok' + or diag $$Error; + + my $got = anyUncompress([ \$output, MultiStream => $ms ]); + + is $got, join('', @uexpected), " Got Expected uncompressed data"; + my @headers = getHeaders(\$output); + is @headers, $ms ? @input : 1, " Header count ok"; + } + + { + title "$TopType - From Array Ref to Filename, MultiStream $ms" ; + + my $lex = new LexFile( my $file3) ; + + # rewind the filehandle + $of->open("<$file1") ; + + my $output ; + ok &$Func(\@input, $file3, MultiStream => $ms, AutoClose => 0), ' Compressed ok' ; + + my $got = anyUncompress([ $file3, MultiStream => $ms ]); + + is $got, join('', @uexpected), " Got Expected uncompressed data"; + my @headers = getHeaders($file3); + is @headers, $ms ? @input : 1, " Header count ok"; + } + + { + title "$TopType - From Array Ref to Filehandle, MultiStream $ms" ; + + my $lex = new LexFile(my $file3) ; + + my $fh3 = new IO::File ">$file3"; + + # rewind the filehandle + $of->open("<$file1") ; + + my $output ; + ok &$Func(\@input, $fh3, MultiStream => $ms, AutoClose => 0), ' Compressed ok' ; + + $fh3->close(); + + my $got = anyUncompress([ $file3, MultiStream => $ms ]); + + is $got, join('', @uexpected), " Got Expected uncompressed data"; + my @headers = getHeaders($file3); + is @headers, $ms ? @input : 1, " Header count ok"; + } + } + } + +# foreach my $bit ($CompressClass) +# { +# my $Error = getErrorRef($bit); +# my $Func = getTopFuncRef($bit); +# my $TopType = getTopFuncName($bit); +# +# my $TopTypeInverse = getInverse($bit); +# my $FuncInverse = getTopFuncRef($TopTypeInverse); +# +# my @inFiles = map { "in$_.tmp" } 1..4; +# my @outFiles = map { "out$_.tmp" } 1..4; +# my $lex = new LexFile(@inFiles, @outFiles); +# +# writeFile($_, "data $_") foreach @inFiles ; +# +# { +# title "$TopType - Hash Ref: to filename" ; +# +# my $output ; +# ok &$Func( { $inFiles[0] => $outFiles[0], +# $inFiles[1] => $outFiles[1], +# $inFiles[2] => $outFiles[2] } ), ' Compressed ok' ; +# +# foreach (0 .. 2) +# { +# my $got = anyUncompress($outFiles[$_]); +# is $got, "data $inFiles[$_]", " Uncompressed $_ matches original"; +# } +# } +# +# { +# title "$TopType - Hash Ref: to buffer" ; +# +# my @buffer ; +# ok &$Func( { $inFiles[0] => \$buffer[0], +# $inFiles[1] => \$buffer[1], +# $inFiles[2] => \$buffer[2] } ), ' Compressed ok' ; +# +# foreach (0 .. 2) +# { +# my $got = anyUncompress(\$buffer[$_]); +# is $got, "data $inFiles[$_]", " Uncompressed $_ matches original"; +# } +# } +# +# { +# title "$TopType - Hash Ref: to undef" ; +# +# my @buffer ; +# my %hash = ( $inFiles[0] => undef, +# $inFiles[1] => undef, +# $inFiles[2] => undef, +# ); +# +# ok &$Func( \%hash ), ' Compressed ok' ; +# +# foreach (keys %hash) +# { +# my $got = anyUncompress(\$hash{$_}); +# is $got, "data $_", " Uncompressed $_ matches original"; +# } +# } +# +# { +# title "$TopType - Filename to Hash Ref" ; +# +# my %output ; +# ok &$Func( $inFiles[0] => \%output), ' Compressed ok' ; +# +# is keys %output, 1, " one pair in hash" ; +# my ($k, $v) = each %output; +# is $k, $inFiles[0], " key is '$inFiles[0]'"; +# my $got = anyUncompress($v); +# is $got, "data $inFiles[0]", " Uncompressed matches original"; +# } +# +# { +# title "$TopType - File Glob to Hash Ref" ; +# +# my %output ; +# ok &$Func( '<in*.tmp>' => \%output), ' Compressed ok' ; +# +# is keys %output, 4, " four pairs in hash" ; +# foreach my $fil (@inFiles) +# { +# ok exists $output{$fil}, " key '$fil' exists" ; +# my $got = anyUncompress($output{$fil}); +# is $got, "data $fil", " Uncompressed matches original"; +# } +# } +# +# +# } + +# foreach my $bit ($CompressClass) +# { +# my $Error = getErrorRef($bit); +# my $Func = getTopFuncRef($bit); +# my $TopType = getTopFuncName($bit); +# +# my $TopTypeInverse = getInverse($bit); +# my $FuncInverse = getTopFuncRef($TopTypeInverse); +# +# my @inFiles = map { "in$_.tmp" } 1..4; +# my @outFiles = map { "out$_.tmp" } 1..4; +# my $lex = new LexFile(@inFiles, @outFiles); +# +# writeFile($_, "data $_") foreach @inFiles ; +# +# +# +# # if (0) +# # { +# # title "$TopType - Hash Ref to Array Ref" ; +# # +# # my @output = ('first') ; +# # ok &$Func( { \@input, \@output } , AutoClose => 0), ' Compressed ok' ; +# # +# # is $output[0], 'first', " Array[0] unchanged"; +# # +# # is_deeply \@input, \@keep, " Input array not changed" ; +# # my @got = shift @output; +# # foreach (@output) { push @got, anyUncompress($_) } +# # +# # is_deeply \@got, ['first', @expected], " Got Expected uncompressed data"; +# # +# # } +# # +# # if (0) +# # { +# # title "$TopType - From Array Ref to Buffer" ; +# # +# # # rewind the filehandle +# # $of->open("<$file1") ; +# # +# # my $output ; +# # ok &$Func(\@input, \$output, AutoClose => 0), ' Compressed ok' ; +# # +# # my $got = anyUncompress(\$output); +# # +# # is $got, join('', @expected), " Got Expected uncompressed data"; +# # } +# # +# # if (0) +# # { +# # title "$TopType - From Array Ref to Filename" ; +# # +# # my ($file3) = ("file3"); +# # my $lex = new LexFile($file3) ; +# # +# # # rewind the filehandle +# # $of->open("<$file1") ; +# # +# # my $output ; +# # ok &$Func(\@input, $file3, AutoClose => 0), ' Compressed ok' ; +# # +# # my $got = anyUncompress($file3); +# # +# # is $got, join('', @expected), " Got Expected uncompressed data"; +# # } +# # +# # if (0) +# # { +# # title "$TopType - From Array Ref to Filehandle" ; +# # +# # my ($file3) = ("file3"); +# # my $lex = new LexFile($file3) ; +# # +# # my $fh3 = new IO::File ">$file3"; +# # +# # # rewind the filehandle +# # $of->open("<$file1") ; +# # +# # my $output ; +# # ok &$Func(\@input, $fh3, AutoClose => 0), ' Compressed ok' ; +# # +# # $fh3->close(); +# # +# # my $got = anyUncompress($file3); +# # +# # is $got, join('', @expected), " Got Expected uncompressed data"; +# # } +# } + + foreach my $bit ($CompressClass + ) + { + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + for my $files ( [qw(a1)], [qw(a1 a2 a3)] ) + { + + my $tmpDir1 = 'tmpdir1'; + my $tmpDir2 = 'tmpdir2'; + my $lex = new LexDir($tmpDir1, $tmpDir2) ; + + mkdir $tmpDir1, 0777; + mkdir $tmpDir2, 0777; + + ok -d $tmpDir1, " Temp Directory $tmpDir1 exists"; + #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist"; + + my @files = map { "$tmpDir1/$_.tmp" } @$files ; + foreach (@files) { writeFile($_, "abc $_") } + + my @expected = map { "abc $_" } @files ; + my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ; + + { + title "$TopType - From FileGlob to FileGlob files [@$files]" ; + + ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' Compressed ok' + or diag $$Error ; + + my @copy = @expected; + for my $file (@outFiles) + { + is anyUncompress($file), shift @copy, " got expected from $file" ; + } + + is @copy, 0, " got all files"; + } + + { + title "$TopType - From FileGlob to Array files [@$files]" ; + + my @buffer = ('first') ; + ok &$Func("<$tmpDir1/a*.tmp>" => \@buffer), ' Compressed ok' + or diag $$Error ; + + is shift @buffer, 'first'; + + my @copy = @expected; + for my $buffer (@buffer) + { + is anyUncompress($buffer), shift @copy, " got expected " ; + } + + is @copy, 0, " got all files"; + } + + foreach my $ms (0, 1) + { + { + title "$TopType - From FileGlob to Buffer files [@$files], MS $ms" ; + + my $buffer ; + ok &$Func("<$tmpDir1/a*.tmp>" => \$buffer, + MultiStream => $ms), ' Compressed ok' + or diag $$Error ; + + #hexDump(\$buffer); + + my $got = anyUncompress([ \$buffer, MultiStream => $ms ]); + + is $got, join("", @expected), " got expected" ; + my @headers = getHeaders(\$buffer); + is @headers, $ms ? @files : 1, " Header count ok"; + } + + { + title "$TopType - From FileGlob to Filename files [@$files], MS $ms" ; + + my $filename = "abcde"; + my $lex = new LexFile($filename) ; + + ok &$Func("<$tmpDir1/a*.tmp>" => $filename, + MultiStream => $ms), ' Compressed ok' + or diag $$Error ; + + #hexDump(\$buffer); + + my $got = anyUncompress([$filename, MultiStream => $ms]); + + is $got, join("", @expected), " got expected" ; + my @headers = getHeaders($filename); + is @headers, $ms ? @files : 1, " Header count ok"; + } + + { + title "$TopType - From FileGlob to Filehandle files [@$files], MS $ms" ; + + my $filename = "abcde"; + my $lex = new LexFile($filename) ; + my $fh = new IO::File ">$filename"; + + ok &$Func("<$tmpDir1/a*.tmp>" => $fh, + MultiStream => $ms, AutoClose => 1), ' Compressed ok' + or diag $$Error ; + + #hexDump(\$buffer); + + my $got = anyUncompress([$filename, MultiStream => $ms]); + + is $got, join("", @expected), " got expected" ; + my @headers = getHeaders($filename); + is @headers, $ms ? @files : 1, " Header count ok"; + } + } + } + + } + + foreach my $bit ($UncompressClass, + 'IO::Uncompress::AnyInflate', + ) + { + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $buffer = "abcde" ; + my $buffer2 = "ABCDE" ; + my $keep_orig = $buffer; + + my $comp = compressBuffer($TopType, $buffer) ; + my $comp2 = compressBuffer($TopType, $buffer2) ; + my $keep_comp = $comp; + + my $incumbent = "incumbent data" ; + + for my $append (0, 1) + { + my $expected = $buffer ; + $expected = $incumbent . $buffer if $append ; + + { + title "$TopType - From Buff to Buff, Append($append)" ; + + my $output ; + $output = $incumbent if $append ; + ok &$Func(\$comp, \$output, Append => $append), ' Uncompressed ok' ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Buff to Array, Append($append)" ; + + my @output = ('first'); + #$output = $incumbent if $append ; + ok &$Func(\$comp, \@output, Append => $append), ' Uncompressed ok' ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output[0], 'first', " Uncompressed matches original"; + is ${ $output[1] }, $buffer, " Uncompressed matches original" + or diag $output[1] ; + is @output, 2, " only 2 elements in the array" ; + } + + { + title "$TopType - From Buff to Filename, Append($append)" ; + + my $lex = new LexFile(my $out_file) ; + if ($append) + { writeFile($out_file, $incumbent) } + else + { ok ! -e $out_file, " Output file does not exist" } + + ok &$Func(\$comp, $out_file, Append => $append), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Buff to Handle, Append($append)" ; + + my $lex = new LexFile(my $out_file) ; + my $of ; + if ($append) { + writeFile($out_file, $incumbent) ; + $of = new IO::File "+< $out_file" ; + } + else { + ok ! -e $out_file, " Output file does not exist" ; + $of = new IO::File "> $out_file" ; + } + isa_ok $of, 'IO::File', ' $of' ; + + ok &$Func(\$comp, $of, Append => $append, AutoClose => 1), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Filename to Filename, Append($append)" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + if ($append) + { writeFile($out_file, $incumbent) } + else + { ok ! -e $out_file, " Output file does not exist" } + + writeFile($in_file, $comp); + + ok &$Func($in_file, $out_file, Append => $append), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Filename to Handle, Append($append)" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + my $out ; + if ($append) { + writeFile($out_file, $incumbent) ; + $out = new IO::File "+< $out_file" ; + } + else { + ok ! -e $out_file, " Output file does not exist" ; + $out = new IO::File "> $out_file" ; + } + isa_ok $out, 'IO::File', ' $out' ; + + writeFile($in_file, $comp); + + ok &$Func($in_file, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Filename to Buffer, Append($append)" ; + + my $lex = new LexFile(my $in_file) ; + writeFile($in_file, $comp); + + my $output ; + $output = $incumbent if $append ; + + ok &$Func($in_file, \$output, Append => $append), ' Uncompressed ok' ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Handle to Filename, Append($append)" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + if ($append) + { writeFile($out_file, $incumbent) } + else + { ok ! -e $out_file, " Output file does not exist" } + + writeFile($in_file, $comp); + my $in = new IO::File "<$in_file" ; + + ok &$Func($in, $out_file, Append => $append), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Handle to Handle, Append($append)" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + my $out ; + if ($append) { + writeFile($out_file, $incumbent) ; + $out = new IO::File "+< $out_file" ; + } + else { + ok ! -e $out_file, " Output file does not exist" ; + $out = new IO::File "> $out_file" ; + } + isa_ok $out, 'IO::File', ' $out' ; + + writeFile($in_file, $comp); + my $in = new IO::File "<$in_file" ; + + ok &$Func($in, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Filename to Buffer, Append($append)" ; + + my $lex = new LexFile(my $in_file) ; + writeFile($in_file, $comp); + my $in = new IO::File "<$in_file" ; + + my $output ; + $output = $incumbent if $append ; + + ok &$Func($in, \$output, Append => $append), ' Uncompressed ok' ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From stdin (via '-') to Buffer content, Append($append) " ; + + my $lex = new LexFile(my $in_file) ; + writeFile($in_file, $comp); + + open(SAVEIN, "<&STDIN"); + my $dummy = fileno SAVEIN ; + ok open(STDIN, "<$in_file"), " redirect STDIN"; + + my $output ; + $output = $incumbent if $append ; + + ok &$Func('-', \$output, Append => $append), ' Uncompressed ok' + or diag $$Error ; + + open(STDIN, "<&SAVEIN"); + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output, $expected, " Uncompressed matches original"; + } + } + + { + title "$TopType - From Handle to Buffer, InputLength" ; + + my $lex = new LexFile(my $in_file, my $out_file) ; + my $out ; + + my $expected = $buffer ; + my $appended = 'appended'; + my $len_appended = length $appended; + writeFile($in_file, $comp . $appended . $comp . $appended) ; + my $in = new IO::File "<$in_file" ; + + ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ; + + is $out, $expected, " Uncompressed matches original"; + + my $buff; + is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok"; + is $buff, $appended, " Appended data ok"; + + $out = ''; + ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ; + + is $out, $expected, " Uncompressed matches original"; + + $buff = ''; + is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok"; + is $buff, $appended, " Appended data ok"; + } + + for my $stdin ('-', *STDIN) # , \*STDIN) + { + title "$TopType - From stdin (via $stdin) to Buffer content, InputLength" ; + + my $lex = new LexFile my $in_file ; + my $expected = $buffer ; + my $appended = 'appended'; + my $len_appended = length $appended; + writeFile($in_file, $comp . $appended ) ; + + open(SAVEIN, "<&STDIN"); + my $dummy = fileno SAVEIN ; + ok open(STDIN, "<$in_file"), " redirect STDIN"; + + my $output ; + + ok &$Func($stdin, \$output, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' + or diag $$Error ; + + my $buff ; + is read(STDIN, $buff, $len_appended), $len_appended, " Length of Appended data ok"; + + is $output, $expected, " Uncompressed matches original"; + is $buff, $appended, " Appended data ok"; + + open(STDIN, "<&SAVEIN"); + } + } + + foreach my $bit ($UncompressClass, + 'IO::Uncompress::AnyInflate', + ) + { + # TODO -- Add Append mode tests + + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $buffer = "abcde" ; + my $keep_orig = $buffer; + + + my $null = compressBuffer($TopType, "") ; + my $undef = compressBuffer($TopType, undef) ; + my $comp = compressBuffer($TopType, $buffer) ; + my $keep_comp = $comp; + + my $incumbent = "incumbent data" ; + + my $lex = new LexFile(my $file1, my $file2) ; + + writeFile($file1, compressBuffer($TopType,"data1")); + writeFile($file2, compressBuffer($TopType,"data2")); + + my $of = new IO::File "<$file1" ; + ok $of, " Created output filehandle" ; + + #my @input = ($file2, \$undef, \$null, \$comp, $of) ; + #my @expected = ('data2', '', '', 'abcde', 'data1'); + my @input = ($file1, $file2); + my @expected = ('data1', 'data2'); + + my @keep = @input ; + + { + title "$TopType - From ArrayRef to Buffer" ; + + my $output ; + ok &$Func(\@input, \$output, AutoClose => 0), ' UnCompressed ok' ; + + is $output, join('', @expected) + } + + { + title "$TopType - From ArrayRef to Filename" ; + + my $lex = new LexFile my $output; + $of->open("<$file1") ; + + ok &$Func(\@input, $output, AutoClose => 0), ' UnCompressed ok' ; + + is readFile($output), join('', @expected) + } + + { + title "$TopType - From ArrayRef to Filehandle" ; + + my $lex = new LexFile my $output; + my $fh = new IO::File ">$output" ; + $of->open("<$file1") ; + + ok &$Func(\@input, $fh, AutoClose => 0), ' UnCompressed ok' ; + $fh->close; + + is readFile($output), join('', @expected) + } + + { + title "$TopType - From Array Ref to Array Ref" ; + + my @output = (\'first') ; + $of->open("<$file1") ; + ok &$Func(\@input, \@output, AutoClose => 0), ' UnCompressed ok' ; + + is_deeply \@input, \@keep, " Input array not changed" ; + is_deeply [map { defined $$_ ? $$_ : "" } @output], + ['first', @expected], + " Got Expected uncompressed data"; + + } + } + + foreach my $bit ($UncompressClass, + 'IO::Uncompress::AnyInflate', + ) + { + # TODO -- Add Append mode tests + + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $tmpDir1 = 'tmpdir1'; + my $tmpDir2 = 'tmpdir2'; + my $lex = new LexDir($tmpDir1, $tmpDir2) ; + + mkdir $tmpDir1, 0777; + mkdir $tmpDir2, 0777; + + ok -d $tmpDir1, " Temp Directory $tmpDir1 exists"; + #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist"; + + my @files = map { "$tmpDir1/$_.tmp" } qw( a1 a2 a3) ; + foreach (@files) { writeFile($_, compressBuffer($TopType, "abc $_")) } + + my @expected = map { "abc $_" } @files ; + my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ; + + { + title "$TopType - From FileGlob to FileGlob" ; + + ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' UnCompressed ok' + or diag $$Error ; + + my @copy = @expected; + for my $file (@outFiles) + { + is readFile($file), shift @copy, " got expected from $file" ; + } + + is @copy, 0, " got all files"; + } + + { + title "$TopType - From FileGlob to Arrayref" ; + + my @output = (\'first'); + ok &$Func("<$tmpDir1/a*.tmp>" => \@output), ' UnCompressed ok' + or diag $$Error ; + + my @copy = ('first', @expected); + for my $data (@output) + { + is $$data, shift @copy, " got expected data" ; + } + + is @copy, 0, " got all files"; + } + + { + title "$TopType - From FileGlob to Buffer" ; + + my $output ; + ok &$Func("<$tmpDir1/a*.tmp>" => \$output), ' UnCompressed ok' + or diag $$Error ; + + is $output, join('', @expected), " got expected uncompressed data"; + } + + { + title "$TopType - From FileGlob to Filename" ; + + my $lex = new LexFile my $output ; + ok ! -e $output, " $output does not exist" ; + ok &$Func("<$tmpDir1/a*.tmp>" => $output), ' UnCompressed ok' + or diag $$Error ; + + ok -e $output, " $output does exist" ; + is readFile($output), join('', @expected), " got expected uncompressed data"; + } + + { + title "$TopType - From FileGlob to Filehandle" ; + + my $output = 'abc' ; + my $lex = new LexFile $output ; + my $fh = new IO::File ">$output" ; + ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1), ' UnCompressed ok' + or diag $$Error ; + + ok -e $output, " $output does exist" ; + is readFile($output), join('', @expected), " got expected uncompressed data"; + } + + } + + foreach my $TopType ($CompressClass + # TODO -- add the inflate classes + ) + { + my $Error = getErrorRef($TopType); + my $Func = getTopFuncRef($TopType); + my $Name = getTopFuncName($TopType); + + title "More write tests" ; + + my $lex = new LexFile(my $file1, my $file2, my $file3) ; + + writeFile($file1, "F1"); + writeFile($file2, "F2"); + writeFile($file3, "F3"); + +# my @data = ( +# [ '[\"ab", \"cd"]', "abcd" ], +# +# [ '[\"a", $fh1, \"bc"]', "aF1bc"], +# ) ; +# +# +# foreach my $data (@data) +# { +# my ($send, $get) = @$data ; +# +# my $fh1 = new IO::File "< $file1" ; +# my $fh2 = new IO::File "< $file2" ; +# my $fh3 = new IO::File "< $file3" ; +# +# title "$send"; +# my ($copy); +# eval "\$copy = $send"; +# my $Answer ; +# ok &$Func($copy, \$Answer), " $Name ok"; +# +# my $got = anyUncompress(\$Answer); +# is $got, $get, " got expected output" ; +# ok ! $$Error, " no error" +# or diag "Error is $$Error"; +# +# } + + title "Array Input Error tests" ; + + my @data = ( + [ '[]', "empty array reference"], + [ '[[]]', "unknown input parameter"], + [ '[[[]]]', "unknown input parameter"], + [ '[[\"ab"], [\"cd"]]', "unknown input parameter"], + [ '[\""]', "not a filename"], + [ '[\undef]', "not a filename"], + [ '[\"abcd"]', "not a filename"], + [ '[\&xx]', "unknown input parameter"], + [ '[$fh2]', "not a filename"], + ) ; + + + foreach my $data (@data) + { + my ($send, $get) = @$data ; + + my $fh1 = new IO::File "< $file1" ; + my $fh2 = new IO::File "< $file2" ; + my $fh3 = new IO::File "< $file3" ; + + title "$send"; + my($copy); + eval "\$copy = $send"; + my $Answer ; + my $a ; + eval { $a = &$Func($copy, \$Answer) }; + ok ! $a, " $Name fails"; + + is $$Error, $get, " got error message"; + + } + + @data = ( + '[""]', + '[undef]', + ) ; + + + foreach my $send (@data) + { + title "$send"; + my($copy); + eval "\$copy = $send"; + my $Answer ; + eval { &$Func($copy, \$Answer) } ; + like $@, mkErr("^$TopFuncName: input filename is undef or null string"), + " got error message"; + + } + } + +} + +# TODO add more error cases + +1; diff --git a/t/lib/compress/prime.pl b/t/lib/compress/prime.pl new file mode 100644 index 0000000000..2c3718029b --- /dev/null +++ b/t/lib/compress/prime.pl @@ -0,0 +1,90 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +our ($extra); + +BEGIN { + # use Test::NoWarnings, if available + $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + +} + +sub run +{ + + my $CompressClass = identify(); + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + + + my $hello = <<EOM ; +hello world +this is a test +some more stuff on this line +ad finally... +EOM + + print "#\n# Testing $UncompressClass\n#\n"; + + my $compressed = mkComplete($CompressClass, $hello); + my $cc = $compressed ; + + plan tests => (length($compressed) * 6 * 7) + 1 + $extra ; + + is anyUncompress(\$cc), $hello ; + + for my $blocksize (1, 2, 13) + { + for my $i (0 .. length($compressed) - 1) + { + for my $useBuf (0 .. 1) + { + print "#\n# BlockSize $blocksize, Length $i, Buffer $useBuf\n#\n" ; + my $lex = new LexFile my $name ; + + my $prime = substr($compressed, 0, $i); + my $rest = substr($compressed, $i); + + my $start ; + if ($useBuf) { + $start = \$rest ; + } + else { + $start = $name ; + writeFile($name, $rest); + } + + #my $gz = new $UncompressClass $name, + my $gz = new $UncompressClass $start, + -Append => 1, + -BlockSize => $blocksize, + -Prime => $prime, + -Transparent => 0 + ; + ok $gz; + ok ! $gz->error() ; + my $un ; + my $status = 1 ; + $status = $gz->read($un) while $status > 0 ; + is $status, 0 ; + ok ! $gz->error() + or print "Error is '" . $gz->error() . "'\n"; + is $un, $hello ; + ok $gz->eof() ; + ok $gz->close() ; + } + } + } +} + +1; diff --git a/t/lib/compress/tied.pl b/t/lib/compress/tied.pl new file mode 100644 index 0000000000..e84a053d00 --- /dev/null +++ b/t/lib/compress/tied.pl @@ -0,0 +1,494 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +our ($BadPerl, $UncompressClass); + +BEGIN +{ + plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" ) + if $] < 5.005 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + my $tests ; + $BadPerl = ($] >= 5.006 and $] <= 5.008) ; + + if ($BadPerl) { + $tests = 242 ; + } + else { + $tests = 250 ; + } + + plan tests => $tests + $extra ; + + use_ok('Compress::Zlib', 2) ; + +} + + +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + + + +sub myGZreadFile +{ + my $filename = shift ; + my $init = shift ; + + + my $fil = new $UncompressClass $filename, + -Strict => 1, + -Append => 1 + ; + + my $data ; + $data = $init if defined $init ; + 1 while $fil->read($data) > 0; + + $fil->close ; + return $data ; +} + +sub run +{ + + my $CompressClass = identify(); + $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + { + next if $BadPerl ; + + + title "Testing $CompressClass"; + + + my $x ; + my $gz = new $CompressClass(\$x); + + my $buff ; + + eval { getc($gz) } ; + like $@, mkErr("^getc Not Available: File opened only for output"); + + eval { read($gz, $buff, 1) } ; + like $@, mkErr("^read Not Available: File opened only for output"); + + eval { <$gz> } ; + like $@, mkErr("^readline Not Available: File opened only for output"); + + } + + { + next if $BadPerl; + $UncompressClass = getInverse($CompressClass); + + title "Testing $UncompressClass"; + + my $gc ; + my $guz = new $CompressClass(\$gc); + $guz->write("abc") ; + $guz->close(); + + my $x ; + my $gz = new $UncompressClass(\$gc); + + my $buff ; + + eval { print $gz "abc" } ; + like $@, mkErr("^print Not Available: File opened only for intput"); + + eval { printf $gz "fmt", "abc" } ; + like $@, mkErr("^printf Not Available: File opened only for intput"); + + #eval { write($gz, $buff, 1) } ; + #like $@, mkErr("^write Not Available: File opened only for intput"); + + } + + { + $UncompressClass = getInverse($CompressClass); + + title "Testing $CompressClass and $UncompressClass"; + + + { + # Write + # these tests come almost 100% from IO::String + + my $lex = new LexFile my $name ; + + my $io = $CompressClass->new($name); + + is $io->tell(), 0 ; + + my $heisan = "Heisan\n"; + print $io $heisan ; + + ok ! $io->eof; + + is $io->tell(), length($heisan) ; + + print($io "a", "b", "c"); + + { + local($\) = "\n"; + print $io "d", "e"; + local($,) = ","; + print $io "f", "g", "h"; + } + + my $foo = "1234567890"; + + ok syswrite($io, $foo, length($foo)) == length($foo) ; + if ( $[ < 5.6 ) + { is $io->syswrite($foo, length $foo), length $foo } + else + { is $io->syswrite($foo), length $foo } + ok $io->syswrite($foo, length($foo)) == length $foo; + ok $io->write($foo, length($foo), 5) == 5; + ok $io->write("xxx\n", 100, -1) == 1; + + for (1..3) { + printf $io "i(%d)", $_; + $io->printf("[%d]\n", $_); + } + select $io; + print "\n"; + select STDOUT; + + close $io ; + + ok $io->eof; + + is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . + ("1234567890" x 3) . "67890\n" . + "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; + + + } + + { + # Read + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $lex = new LexFile my $name ; + + my $iow = new $CompressClass $name ; + print $iow $str ; + close $iow; + + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name ; + + ok ! $io->eof; + is $io->tell(), 0 ; + my @lines = <$io>; + is @lines, 6 + or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; + is $lines[1], "of a paragraph\n" ; + is join('', @lines), $str ; + is $., 6; + is $io->tell(), length($str) ; + + ok $io->eof; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined(<$io>) || + defined($io->getc) || + read($io, $buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok !$io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = <$io>; + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = <$io>; + ok $io->eof; + ok @lines == 2 + or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# $lines[0]\n"; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (<$io>) { + push(@lines, $_); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 + or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + + if (! $BadPerl) { + eval { read($io, $buf, -1) } ; + like $@, mkErr("length parameter is negative"); + } + + is read($io, $buf, 0), 0, "Requested 0 bytes" ; + + ok read($io, $buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok sysread($io, $buf, 3, 2) == 3 ; + ok $buf eq "Ths i" + or print "# [$buf]\n" ;; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + } + + { + # Read from non-compressed file + + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $lex = new LexFile my $name ; + + writeFile($name, $str); + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name, -Transparent => 1 ; + + ok defined $io; + ok ! $io->eof; + ok $io->tell() == 0 ; + my @lines = <$io>; + ok @lines == 6; + ok $lines[1] eq "of a paragraph\n" ; + ok join('', @lines) eq $str ; + ok $. == 6; + ok $io->tell() == length($str) ; + + ok $io->eof; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined(<$io>) || + defined($io->getc) || + read($io, $buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = <$io>; + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = <$io>; + ok $io->eof; + ok @lines == 2 + or print "# exected 2 lines, got " . scalar(@lines) . "\n"; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# [$lines[0]]\n" ; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (<$io>) { + push(@lines, $_); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + ok read($io, $buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok sysread($io, $buf, 3, 2) == 3 ; + ok $buf eq "Ths i"; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + + } + + { + # Vary the length parameter in a read + + my $str = <<EOT; +x +x +This is an example +of a paragraph + + +and a single line. + +EOT + $str = $str x 100 ; + + + foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) + { + foreach my $trans (0, 1) + { + foreach my $append (0, 1) + { + title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; + + my $lex = new LexFile my $name ; + + if ($trans) { + writeFile($name, $str) ; + } + else { + my $iow = new $CompressClass $name ; + print $iow $str ; + close $iow; + } + + + my $io = $UncompressClass->new($name, + -Append => $append, + -Transparent => $trans); + + my $buf; + + is $io->tell(), 0; + + if ($append) { + 1 while $io->read($buf, $bufsize) > 0; + } + else { + my $tmp ; + $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; + } + is length $buf, length $str; + ok $buf eq $str ; + ok ! $io->error() ; + ok $io->eof; + } + } + } + } + + } +} + +1; diff --git a/t/lib/compress/truncate.pl b/t/lib/compress/truncate.pl new file mode 100644 index 0000000000..55e4719f44 --- /dev/null +++ b/t/lib/compress/truncate.pl @@ -0,0 +1,251 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 2374 + $extra; + +} + +sub run +{ + my $CompressClass = identify(); + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + my $hello = <<EOM ; +hello world +this is a test +some more stuff on this line +and finally... +EOM + + my $blocksize = 10 ; + + + my ($info, $compressed) = mkComplete($CompressClass, $hello); + + my $header_size = $info->{HeaderLength}; + my $trailer_size = $info->{TrailerLength}; + my $fingerprint_size = $info->{FingerprintLength}; + ok 1, "Compressed size is " . length($compressed) ; + ok 1, "Fingerprint size is $fingerprint_size" ; + ok 1, "Header size is $header_size" ; + ok 1, "Trailer size is $trailer_size" ; + + for my $trans ( 0 .. 1) + { + title "Truncating $CompressClass, Transparent $trans"; + + + foreach my $i (1 .. $fingerprint_size-1) + { + my $lex = new LexFile my $name ; + + title "Fingerprint Truncation - 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 ; + ok $gz->read($buff) == length($part) ; + ok $buff eq $part ; + ok $gz->eof() ; + $gz->close(); + } + else { + ok !$gz; + } + + } + + # + # Any header corruption past the fingerprint is considered catastrophic + # so even if Transparent is set, it should still fail + # + foreach my $i ($fingerprint_size .. $header_size -1) + { + my $lex = new LexFile my $name ; + + title "Header Truncation - length $i"; + + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + ok ! defined new $UncompressClass $name, + -BlockSize => $blocksize, + -Transparent => $trans; + #ok $gz->eof() ; + } + + + foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size) + { + my $lex = new LexFile my $name ; + + title "Compressed Data Truncation - 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 = 0 ; + $status = $gz->read($un) while $status >= 0 ; + ok $status < 0 ; + ok $gz->eof() ; + ok $gz->error() ; + $gz->close(); + } + + # RawDeflate does not have a trailer + next if $CompressClass eq 'IO::Compress::RawDeflate' ; + + title "Compressed Trailer Truncation"; + foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 ) + { + foreach my $lax (0, 1) + { + my $lex = new LexFile my $name ; + + ok 1, "Length $i, Lax $lax" ; + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + ok my $gz = new $UncompressClass $name, + -BlockSize => $blocksize, + -Strict => !$lax, + -Append => 1, + -Transparent => $trans; + my $un = ''; + my $status = 1 ; + $status = $gz->read($un) while $status > 0 ; + + if ($lax) + { + is $un, $hello; + is $status, 0 + or diag "Status $status Error is " . $gz->error() ; + ok $gz->eof() + or diag "Status $status Error is " . $gz->error() ; + ok ! $gz->error() ; + } + else + { + ok $status < 0 + or diag "Status $status Error is " . $gz->error() ; + ok $gz->eof() + or diag "Status $status Error is " . $gz->error() ; + ok $gz->error() ; + } + + $gz->close(); + } + } + } +} + +1; + +__END__ + + +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 = 0 ; + $status = $gz->read($un) while $status >= 0 ; + ok $status < 0 ; + ok $gz->eof() ; + ok $gz->error() ; + $gz->close(); + } + } + +} + diff --git a/t/lib/compress/zlib-generic.pl b/t/lib/compress/zlib-generic.pl new file mode 100644 index 0000000000..05b0de9bca --- /dev/null +++ b/t/lib/compress/zlib-generic.pl @@ -0,0 +1,233 @@ + +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN +{ + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 49 + $extra ; +} + + + +my $CompressClass = identify(); +my $UncompressClass = getInverse($CompressClass); +my $Error = getErrorRef($CompressClass); +my $UnError = getErrorRef($UncompressClass); + +use Compress::Zlib; +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + +sub myGZreadFile +{ + my $filename = shift ; + my $init = shift ; + + + my $fil = new $UncompressClass $filename, + -Strict => 1, + -Append => 1 + ; + + my $data = ''; + $data = $init if defined $init ; + 1 while $fil->read($data) > 0; + + $fil->close ; + return $data ; +} + + +{ + + title "Testing $CompressClass Errors"; + +} + + +{ + title "Testing $UncompressClass Errors"; + +} + +{ + title "Testing $CompressClass and $UncompressClass"; + + { + title "flush" ; + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + my $x ; + ok $x = new $CompressClass $name ; + + ok $x->write($hello), "write" ; + ok $x->flush(Z_FINISH), "flush"; + ok $x->close, "close" ; + } + + { + my $uncomp; + ok my $x = new $UncompressClass $name, -Append => 1 ; + + my $len ; + 1 while ($len = $x->read($uncomp)) > 0 ; + + is $len, 0, "read returned 0"; + + ok $x->close ; + is $uncomp, $hello ; + } + } + + + if ($CompressClass ne 'RawDeflate') + { + # write empty file + #======================================== + + my $buffer = ''; + { + my $x ; + ok $x = new $CompressClass(\$buffer) ; + ok $x->close ; + + } + + my $keep = $buffer ; + my $uncomp= ''; + { + my $x ; + ok $x = new $UncompressClass(\$buffer, Append => 1) ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close ; + } + + ok $uncomp eq '' ; + ok $buffer eq $keep ; + + } + + + { + title "inflateSync on plain file"; + + my $hello = "I am a HAL 9000 computer" x 2001 ; + + my $k = new $UncompressClass(\$hello, Transparent => 1); + ok $k ; + + # Skip to the flush point -- no-op for plain file + my $status = $k->inflateSync(); + is $status, 1 + or diag $k->error() ; + + my $rest; + is $k->read($rest, length($hello)), length($hello) + or diag $k->error() ; + ok $rest eq $hello ; + + ok $k->close(); + } + + { + title "$CompressClass: inflateSync for real"; + + # create a deflate stream with flush points + + my $hello = "I am a HAL 9000 computer" x 2001 ; + my $goodbye = "Will I dream?" x 2010; + my ($x, $err, $answer, $X, $Z, $status); + my $Answer ; + + ok ($x = new $CompressClass(\$Answer)); + ok $x ; + + is $x->write($hello), length($hello); + + # create a flush point + ok $x->flush(Z_FULL_FLUSH) ; + + is $x->write($goodbye), length($goodbye); + + ok $x->close() ; + + my $k; + $k = new $UncompressClass(\$Answer, BlockSize => 1); + ok $k ; + + my $initial; + is $k->read($initial, 1), 1 ; + is $initial, substr($hello, 0, 1); + + # Skip to the flush point + $status = $k->inflateSync(); + is $status, 1, " inflateSync returned 1" + or diag $k->error() ; + + my $rest; + is $k->read($rest, length($hello) + length($goodbye)), + length($goodbye) + or diag $k->error() ; + ok $rest eq $goodbye, " got expected output" ; + + ok $k->close(); + } + + { + title "$CompressClass: inflateSync no FLUSH point"; + + # create a deflate stream with flush points + + my $hello = "I am a HAL 9000 computer" x 2001 ; + my ($x, $err, $answer, $X, $Z, $status); + my $Answer ; + + ok ($x = new $CompressClass(\$Answer)); + ok $x ; + + is $x->write($hello), length($hello); + + ok $x->close() ; + + my $k = new $UncompressClass(\$Answer, BlockSize => 1); + ok $k ; + + my $initial; + is $k->read($initial, 1), 1 ; + is $initial, substr($hello, 0, 1); + + # Skip to the flush point + $status = $k->inflateSync(); + is $status, 0 + or diag $k->error() ; + + ok $k->close(); + is $k->inflateSync(), 0 ; + } + +} + + +1; + + + + |