From: Paul Marquess Date: Mon, 9 Jan 2006 20:25:00 +0000 (+0000) Subject: Compress::Zlib becomes zlib agnostic X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1a6a845317ff5e6bc844195898061e5a9910928d;p=p5sagit%2Fp5-mst-13.2.git Compress::Zlib becomes zlib agnostic From: "Paul Marquess" Message-ID: <002101c6155a$c5886c90$1340100a@myopwv.com> p4raw-id: //depot/perl@26761 --- diff --git a/MANIFEST b/MANIFEST index 4c8e8b2..8c5ad2a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -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 93ddaeb..1b74408 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 d804fa1..4226634 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 < '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 ') - : () - ), + : (), + ) ; 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 efeb32f..ec1aee4 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 9a3598b..34e57e7 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 interface: =item 1 -If you want to to open either STDIN or STDOUT with C, you can +If you want to to open either STDIN or STDOUT with C, 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 version 2.x, the C interface has been completely -rewritten to use the L for writing gzip files and -L for reading gzip files. +rewritten to use the L for writing gzip files and +L for reading gzip files. =item 3 @@ -997,9 +936,9 @@ Added C. =back -A more complete and flexible interface for reading/writing gzip files/buffers -is included with this module. See L and -L for more details. +A more complete and flexible interface for reading/writing gzip +files/buffers is included with this module. See L and +L for more details. =over 5 @@ -1007,14 +946,14 @@ L for more details. =item B<$gz = gzopen($filehandle, $mode)> -This function opens either the I file C<$filename> for reading or writing -or attaches to the opened filehandle, C<$filehandle>. It returns an object on -success and C on failure. +This function opens either the I file C<$filename> for reading or +writing or attaches to the opened filehandle, C<$filehandle>. +It returns an object on success and C 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 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 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-Egzseek($offset, $whence) ;> -Sets the file position of the - Provides a sub-set of the C 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 for an alternative way to carry out in-memory gzip +See L 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 for an alternative way to carry out in-memory gzip +See L 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 compatible with the Unix commands of the same name. -See L and L included with +See L and L 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 -refer to the I documentation for I. +To uncompress an RFC1950 data stream, set C to a positive number. + +To uncompress an RFC1951 data stream, set C to C<-MAX_WBITS>. + +For a full definition of the meaning and valid values for C refer +to the I documentation for I. Defaults to C<-WindowBits =EMAX_WBITS>. @@ -1734,7 +1675,7 @@ buffer size. my ($i, $status) = new Compress::Zlib::Inflate( -Bufsize => 300 ) ; -=head2 B< $status = $i-Einflate($input, $output) > +=head2 B< $status = $i-Einflate($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 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 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 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-Einflate>. + +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-EinflateSync($input)> This method can be used to attempt to recover good data from a compressed @@ -1899,8 +1879,12 @@ the default) is C<-Method =EZ_DEFLATED>. =item B<-WindowBits> -For a definition of the meaning and valid values for C -refer to the I documentation for I. +To create an RFC1950 data stream, set C to a positive number. + +To create an RFC1951 data stream, set C to C<-MAX_WBITS>. + +For a full definition of the meaning and valid values for C refer +to the I documentation for I. Defaults to C<-WindowBits =EMAX_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 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 -refer to the I documentation for I. +To uncompress an RFC1950 data stream, set C to a positive number. + +To uncompress an RFC1951 data stream, set C to C<-MAX_WBITS>. + +For a full definition of the meaning and valid values for C refer +to the I documentation for I. Defaults to C<-WindowBits =EMAX_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 8bf75f1..b7cd48a 100644 --- a/ext/Compress/Zlib/Zlib.xs +++ b/ext/Compress/Zlib/Zlib.xs @@ -33,6 +33,14 @@ #include +/* 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 358dfaa..531b347 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 0000000..ef82024 --- /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 36d6f64..a01ab9b 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 69befce..540f892 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 d89ec67..71fb45b 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 0000000..28ca794 --- /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 0000000..db90e97 --- /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 b854226..9e7c217 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 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 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 are strings that are delimired by <>. +Notice how both parameters to C 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, C<*.tar.gz>, is an I. @@ -528,7 +528,7 @@ derived from the I filename. C has been kept simple deliberately, so it isn't intended to solve all filename mapping operations. Under the hood C (or for -older verions of Perl, C) is used to match the files, so you +older versions of Perl, C) 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 0000000..e084612 --- /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 8e7e724..de438f3 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. =head1 Functional Interface -A top-level function, C, is provided to carry out "one-shot" -compression between buffers and/or files. For finer control over the compression process, see the L section. +A top-level function, C, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L +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 expects -at least two parameters, C<$input> and C<$output>. + +C 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 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 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 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 section below. =item AutoClose =E 0|1 -This option applies to any input or output data streams to C -that are filehandles. +This option applies to any input or output data streams to +C that are filehandles. If C is specified, and the value is true, it will result in all input and/or output filehandles being closed once C has @@ -317,6 +392,16 @@ This parameter defaults to 0. +=item BinModeIn =E 0|1 + +When reading from a file or filehandle, set C before reading. + +Defaults to 0. + + + + + =item -Append =E 0|1 TODO @@ -437,9 +522,9 @@ C is any combination of the following options: =item -AutoClose =E 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 method is called or the C object is -destroyed. +specified, and the value is true, it will result in the C<$output> being +closed once either the C method is called or the C +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 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 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 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 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 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 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 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 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 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 built-in. +has the same behaviour as the C 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 e8e070b..840a687 100644 --- a/ext/Compress/Zlib/lib/IO/Compress/Gzip.pm +++ b/ext/Compress/Zlib/lib/IO/Compress/Gzip.pm @@ -6,89 +6,12 @@ require 5.004 ; use strict ; use warnings; -# create RFC1952 - -require Exporter ; - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError); - -$VERSION = '2.000_05'; -$GzipError = '' ; - -@ISA = qw(Exporter IO::BaseDeflate); -@EXPORT_OK = qw( $GzipError gzip ) ; -%EXPORT_TAGS = %IO::BaseDeflate::EXPORT_TAGS ; -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; -Exporter::export_ok_tags('all'); - -sub new -{ - my $pkg = shift ; - return IO::BaseDeflate::new($pkg, 'rfc1952', undef, \$GzipError, @_); -} - - -sub gzip -{ - return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1952', \$GzipError, @_); -} - -package IO::BaseDeflate; +use IO::Compress::RawDeflate; use Compress::Zlib 2 ; -use Compress::Zlib::Common; -use Compress::Zlib::FileConstants; -use Compress::Zlib::ParseParameters; +use Compress::Zlib::Common qw(:Status createSelfTiedObject); use Compress::Gzip::Constants; -use IO::Uncompress::Gunzip; - -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 - }], - - ); - -{ - my %seen; - foreach (keys %EXPORT_TAGS ) - { - push @{$EXPORT_TAGS{constants}}, - grep { !$seen{$_}++ } - @{ $EXPORT_TAGS{$_} } - } - $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ; -} - -Exporter::export_ok_tags('all'); - BEGIN { @@ -97,488 +20,83 @@ BEGIN else { *noUTF8 = sub {} } } - - -$VERSION = '2.000_03'; - -#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 error -{ - my $self = shift ; - return ${ *$self->{Error} } ; -} - -sub errorNo -{ - my $self = shift ; - return ${ *$self->{ErrorNo} } ; -} - -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 mkDeflateHeader ($) -{ - my $param = shift ; - - my $level = $param->value('Level'); - my $strategy = $param->value('Strategy'); +require Exporter ; - my $lflag ; - $level = 6 - if $level == Z_DEFAULT_COMPRESSION ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError); - 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 ; - } +$VERSION = '2.000_07'; +$GzipError = '' ; - #my $wbits = (MAX_WBITS - 8) << 4 ; - my $wbits = 7; - mkDeflateHdr(ZLIB_CMF_CM_DEFLATED, $wbits, $lflag); -} +@ISA = qw(Exporter IO::Compress::RawDeflate); +@EXPORT_OK = qw( $GzipError gzip ) ; +%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); -sub mkGzipHeader +sub new { - my $param = shift ; - - # stort-circuit if a minimal header is requested. - return GZIP_MINIMUM_HEADER if $param->value('Minimal') ; - - # METHOD - my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ; - - # FLAGS - my $flags = GZIP_FLG_DEFAULT ; - $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ; - $flags |= GZIP_FLG_FHCRC if $param->value('HeaderCRC') ; - $flags |= GZIP_FLG_FEXTRA if $param->wantValue('ExtraField') ; - $flags |= GZIP_FLG_FNAME if $param->wantValue('Name') ; - $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ; - - # MTIME - my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ; - - # EXTRA FLAGS - my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT); - - # OS CODE - my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ; - - - my $out = pack("C4 V C C", - GZIP_ID1, # ID1 - GZIP_ID2, # ID2 - $method, # Compression Method - $flags, # Flags - $time, # Modification Time - $extra_flags, # Extra Flags - $os_code, # Operating System Code - ) ; - - # EXTRA - if ($flags & GZIP_FLG_FEXTRA) { - my $extra = $param->value('ExtraField') ; - $out .= pack("v", length $extra) . $extra ; - } - - # NAME - if ($flags & GZIP_FLG_FNAME) { - my $name .= $param->value('Name') ; - $name =~ s/\x00.*$//; - $out .= $name ; - # Terminate the filename with NULL unless it already is - $out .= GZIP_NULL_BYTE - if !length $name or - substr($name, 1, -1) ne GZIP_NULL_BYTE ; - } - - # COMMENT - if ($flags & GZIP_FLG_FCOMMENT) { - my $comment .= $param->value('Comment') ; - $comment =~ s/\x00.*$//; - $out .= $comment ; - # Terminate the comment with NULL unless it already is - $out .= GZIP_NULL_BYTE - if ! length $comment or - substr($comment, 1, -1) ne GZIP_NULL_BYTE; - } - - # HEADER CRC - $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ; + my $class = shift ; - noUTF8($out); + my $obj = createSelfTiedObject($class, \$GzipError); - return $out ; + $obj->_create(undef, @_); } -sub ExtraFieldError -{ - return "Error with ExtraField Parameter: $_[0]" ; -} -sub validateExtraFieldPair +sub gzip { - my $pair = shift ; - my $lax = shift ; - - return ExtraFieldError("Not an array ref") - unless ref $pair && ref $pair eq 'ARRAY'; - - return ExtraFieldError("SubField must have two parts") - unless @$pair == 2 ; - - return ExtraFieldError("SubField ID is a reference") - if ref $pair->[0] ; - - return ExtraFieldError("SubField Data is a reference") - if ref $pair->[1] ; - - # ID is exactly two chars - return ExtraFieldError("SubField ID not two chars long") - unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ; - - # Check that the 2nd byte of the ID isn't 0 - return ExtraFieldError("SubField ID 2nd byte is 0x00") - if ! $lax && substr($pair->[0], 1, 1) eq "\x00" ; - - return ExtraFieldError("SubField Data too long") - if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ; - - - return undef ; + my $obj = createSelfTiedObject(undef, \$GzipError); + return $obj->_def(@_); } -sub parseExtra -{ - my $data = shift ; - my $lax = shift ; - - return undef - if $lax ; - - my $XLEN = length $data ; - - return ExtraFieldError("Too Large") - if $XLEN > GZIP_FEXTRA_MAX_SIZE; - - my $offset = 0 ; - while ($offset < $XLEN) { - - return ExtraFieldError("FEXTRA Body") - if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; - - my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); - $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; - - my $subLen = unpack("v", substr($data, $offset, - GZIP_FEXTRA_SUBFIELD_LEN_SIZE)); - $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; - - return ExtraFieldError("FEXTRA Body") - if $offset + $subLen > $XLEN ; - - my $bad = validateExtraFieldPair( [$id, - substr($data, $offset, $subLen)], $lax ); - return $bad if $bad ; - - $offset += $subLen ; - } - - return undef ; -} +#sub newHeader +#{ +# my $self = shift ; +# #return GZIP_MINIMUM_HEADER ; +# return $self->mkHeader(*$self->{Got}); +#} -sub parseExtraField +sub getExtraParams { my $self = shift ; - my $got = shift ; - my $lax = shift ; - - # ExtraField can be any of - # - # -ExtraField => $data - # -ExtraField => [$id1, $data1, - # $id2, $data2] - # ... - # ] - # -ExtraField => [ [$id1 => $data1], - # [$id2 => $data2], - # ... - # ] - # -ExtraField => { $id1 => $data1, - # $id2 => $data2, - # ... - # } + use Compress::Zlib::ParseParameters; - return undef - unless $got->parsed('ExtraField') ; - - return parseExtra($got->value('ExtraField'), $lax) - unless ref $got->value('ExtraField') ; - - my $data = $got->value('ExtraField'); - my $out = '' ; - - if (ref $data eq 'ARRAY') { - if (ref $data->[0]) { - - foreach my $pair (@$data) { - return ExtraFieldError("Not list of lists") - unless ref $pair eq 'ARRAY' ; - - my $bad = validateExtraFieldPair($pair, $lax) ; - return $bad if $bad ; - - $out .= $pair->[0] . pack("v", length $pair->[1]) . - $pair->[1] ; - } - } - else { - return ExtraFieldError("Not even number of elements") - unless @$data % 2 == 0; - - for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) { - my $bad = validateExtraFieldPair([$data->[$ix], $data->[$ix+1]], $lax) ; - return $bad if $bad ; - - $out .= $data->[$ix] . pack("v", length $data->[$ix+1]) . - $data->[$ix+1] ; - } - } - } - elsif (ref $data eq 'HASH') { - while (my ($id, $info) = each %$data) { - my $bad = validateExtraFieldPair([$id, $info], $lax); - return $bad if $bad ; - - $out .= $id . pack("v", length $info) . $info ; - } - } - else { - return ExtraFieldError("Not a scalar, array ref or hash ref") ; - } - - $got->value('ExtraField' => $out); - - 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], - + return ( # zlib behaviour - #'Method' => [Parse_unsigned, Z_DEFLATED], - 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION], - 'Strategy' => [Parse_signed, Z_DEFAULT_STRATEGY], + $self->getZlibParams(), # 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 ; + '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], + + ); } -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'); +sub ckParams +{ + my $self = shift ; + my $got = shift ; - my $obj = bless Symbol::gensym(), ref($class) || $class; - tie *$obj, $obj if $] >= 5.005; + # gzip always needs crc32 + $got->value('CRC32' => 1); - *$obj->{Closed} = 1 ; - $$error_ref = '' ; - *$obj->{Error} = $error_ref ; + return 1 + if $got->value('Merge') ; 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) ; @@ -589,11 +107,11 @@ sub new if ($got->parsed('Name') && defined $got->value('Name')) { my $name = $got->value('Name'); - return $obj->saveErrorString(undef, "Null Character found in Name", + return $self->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", + return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Name", Z_DATA_ERROR) if ! $lax && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; } @@ -601,11 +119,11 @@ sub new if ($got->parsed('Comment') && defined $got->value('Comment')) { my $comment = $got->value('Comment'); - return $obj->saveErrorString(undef, "Null Character found in Comment", + return $self->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", + return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment", Z_DATA_ERROR) if ! $lax && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o; } @@ -613,7 +131,7 @@ sub new 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'") + return $self->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'") if $value < 0 || $value > 255 ; } @@ -630,894 +148,281 @@ sub new if ($got->parsed('ExtraField')) { - my $bad = $obj->parseExtraField($got, $lax) ; - return $obj->saveErrorString(undef, $bad, Z_DATA_ERROR) + my $bad = $self->parseExtraField($got, $lax) ; + return $self->saveErrorString(undef, $bad, Z_DATA_ERROR) if $bad ; my $len = length $got->value('ExtraField') ; - return $obj->saveErrorString(undef, ExtraFieldError("Too Large"), + return $self->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() ; + return 1; } -sub _wr2 +sub mkTrailer { 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 -{ - 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 pack("V V", *$self->{Compress}->crc32(), + *$self->{UnCompSize_32bit}); } -sub TIEHANDLE +sub getInverseClass { - return $_[0] if ref($_[0]); - die "OOPS\n" ; -} - -sub UNTIE -{ - my $self = shift ; + return ('IO::Uncompress::Gunzip', + \$IO::Uncompress::Gunzip::GunzipError); } -sub DESTROY +sub getFileInfo { my $self = shift ; - $self->close() ; - - # TODO - memory leak with 5.8.0 - this isn't called until - # global destruction - # - %{ *$self } = () ; - undef $self ; -} + my $params = shift; + my $filename = shift ; + my $defaultTime = (stat($filename))[9] ; -#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 ; -#} - + $params->value('Name' => $filename) + if ! $params->parsed('Name') ; -#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 ; -#} + $params->value('Time' => $defaultTime) + if ! $params->parsed('Time') ; +} -sub syswrite +sub mkHeader { my $self = shift ; + my $param = shift ; - my $buffer ; - if (ref $_[0] ) { - croak *$self->{ClassName} . "::write: not a scalar reference" - unless ref $_[0] eq 'SCALAR' ; - $buffer = $_[0] ; - } - else { - $buffer = \$_[0] ; - } + # stort-circuit if a minimal header is requested. + return GZIP_MINIMUM_HEADER if $param->value('Minimal') ; - 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; - } + # METHOD + my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ; - $buffer = \substr($$buffer, $offset, $len) ; - } + # FLAGS + my $flags = GZIP_FLG_DEFAULT ; + $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ; + $flags |= GZIP_FLG_FHCRC if $param->value('HeaderCRC') ; + $flags |= GZIP_FLG_FEXTRA if $param->wantValue('ExtraField') ; + $flags |= GZIP_FLG_FNAME if $param->wantValue('Name') ; + $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ; + + # MTIME + my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ; - 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 ; - } + # EXTRA FLAGS + my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT); -# if (*$self->{Encoding}) { -# $$buffer = *$self->{Encoding}->encode($$buffer); -# } + # OS CODE + my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ; - #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 ; + my $out = pack("C4 V C C", + GZIP_ID1, # ID1 + GZIP_ID2, # ID2 + $method, # Compression Method + $flags, # Flags + $time, # Modification Time + $extra_flags, # Extra Flags + $os_code, # Operating System Code + ) ; - if ( defined *$self->{FH} and length ${ *$self->{Buffer} }) { - defined *$self->{FH}->write( ${ *$self->{Buffer} }, length ${ *$self->{Buffer} } ) - or return $self->saveErrorString(undef, $!, $!); - ${ *$self->{Buffer} } = '' ; + # EXTRA + if ($flags & GZIP_FLG_FEXTRA) { + my $extra = $param->value('ExtraField') ; + $out .= pack("v", length $extra) . $extra ; } - return $buffer_length; -} - -sub print -{ - my $self = shift; - - #if (ref $self) { - # $self = *$self{GLOB} ; - #} + # NAME + if ($flags & GZIP_FLG_FNAME) { + my $name .= $param->value('Name') ; + $name =~ s/\x00.*$//; + $out .= $name ; + # Terminate the filename with NULL unless it already is + $out .= GZIP_NULL_BYTE + if !length $name or + substr($name, 1, -1) ne GZIP_NULL_BYTE ; + } - 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("", @_)); - } + # COMMENT + if ($flags & GZIP_FLG_FCOMMENT) { + my $comment .= $param->value('Comment') ; + $comment =~ s/\x00.*$//; + $out .= $comment ; + # Terminate the comment with NULL unless it already is + $out .= GZIP_NULL_BYTE + if ! length $comment or + substr($comment, 1, -1) ne GZIP_NULL_BYTE; } -} -sub printf -{ - my $self = shift; - my $fmt = shift; - defined $self->syswrite(sprintf($fmt, @_)); -} + # HEADER CRC + $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ; + noUTF8($out); + return $out ; +} -sub flush +sub ExtraFieldError { - 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; + return "Error with ExtraField Parameter: $_[0]" ; } -sub newStream +sub validateExtraFieldPair { - 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 ; + my $pair = shift ; + my $lax = shift ; - return 1 ; -} + return ExtraFieldError("Not an array ref") + unless ref $pair && ref $pair eq 'ARRAY'; -sub _writeTrailer -{ - my $self = shift ; - my $nextHeader = shift || '' ; + return ExtraFieldError("SubField must have two parts") + unless @$pair == 2 ; - my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ; - return $self->saveErrorString(0,"Deflate Error: $status") - if $self->saveStatus($status) != Z_OK ; + return ExtraFieldError("SubField ID is a reference") + if ref $pair->[0] ; - if (*$self->{OutputGzip}) { - ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(), - *$self->{ISize} ); - ${ *$self->{Buffer} } .= $nextHeader ; - } + return ExtraFieldError("SubField Data is a reference") + if ref $pair->[1] ; - if (*$self->{OutputDeflate}) { - ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() ); - ${ *$self->{Buffer} } .= *$self->{Header} ; - } + # ID is exactly two chars + return ExtraFieldError("SubField ID not two chars long") + unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ; - return 1 if ! defined *$self->{FH} ; + # Check that the 2nd byte of the ID isn't 0 + return ExtraFieldError("SubField ID 2nd byte is 0x00") + if ! $lax && substr($pair->[0], 1, 1) eq "\x00" ; - defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} }) - or return $self->saveErrorString(0, $!, $!); + return ExtraFieldError("SubField Data too long") + if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ; - ${ *$self->{Buffer} } = '' ; - return 1; + return undef ; } -sub close +sub parseExtra { - my $self = shift ; - - return 1 if *$self->{Closed} || ! *$self->{Deflate} ; - *$self->{Closed} = 1 ; + my $data = shift ; + my $lax = shift ; - untie *$self - if $] >= 5.008 ; + return undef + if $lax ; - if (0) { - $self->_writeTrailer() - or return 0 ; - } - else { + my $XLEN = length $data ; - - my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ; - return $self->saveErrorString(0,"Deflate Error: $status") - if $self->saveStatus($status) != Z_OK ; + return ExtraFieldError("Too Large") + if $XLEN > GZIP_FEXTRA_MAX_SIZE; - if (*$self->{OutputGzip}) { - ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(), - *$self->{ISize} ); - } + my $offset = 0 ; + while ($offset < $XLEN) { - if (*$self->{OutputDeflate}) { - ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() ); - } + return ExtraFieldError("FEXTRA Body") + if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; + my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); + $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; - return 1 if ! defined *$self->{FH} ; + my $subLen = unpack("v", substr($data, $offset, + GZIP_FEXTRA_SUBFIELD_LEN_SIZE)); + $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; - defined *$self->{FH}->write(${ *$self->{Buffer} }, length( ${ *$self->{Buffer} } )) - or return $self->saveErrorString(0, $!, $!); + return ExtraFieldError("FEXTRA Body") + if $offset + $subLen > $XLEN ; - ${ *$self->{Buffer} } = '' ; - } + my $bad = validateExtraFieldPair( [$id, + substr($data, $offset, $subLen)], $lax ); + return $bad if $bad ; - 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 ; + $offset += $subLen ; } - - return 1; + + return undef ; } -sub deflateParams +sub parseExtraField { 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; -} - + my $got = shift ; + my $lax = shift ; -#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() ; -#} + # ExtraField can be any of + # + # -ExtraField => $data + # -ExtraField => [$id1, $data1, + # $id2, $data2] + # ... + # ] + # -ExtraField => [ [$id1 => $data1], + # [$id2 => $data2], + # ... + # ] + # -ExtraField => { $id1 => $data1, + # $id2 => $data2, + # ... + # } + + return undef + unless $got->parsed('ExtraField') ; -sub tell -{ - my $self = shift ; + return parseExtra($got->value('ExtraField'), $lax) + unless ref $got->value('ExtraField') ; - #return *$self->{Deflate}->total_in(); - return *$self->{BytesWritten} ; -} + my $data = $got->value('ExtraField'); + my $out = '' ; -sub eof -{ - my $self = shift ; + if (ref $data eq 'ARRAY') { + if (ref $data->[0]) { - return *$self->{Closed} ; -} + foreach my $pair (@$data) { + return ExtraFieldError("Not list of lists") + unless ref $pair eq 'ARRAY' ; + my $bad = validateExtraFieldPair($pair, $lax) ; + return $bad if $bad ; -sub seek -{ - my $self = shift ; - my $position = shift; - my $whence = shift ; + $out .= $pair->[0] . pack("v", length $pair->[1]) . + $pair->[1] ; + } + } + else { + return ExtraFieldError("Not even number of elements") + unless @$data % 2 == 0; - my $here = $self->tell() ; - my $target = 0 ; + for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) { + my $bad = validateExtraFieldPair([$data->[$ix], $data->[$ix+1]], $lax) ; + return $bad if $bad ; - #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - use IO::Handle ; + $out .= $data->[$ix] . pack("v", length $data->[$ix+1]) . + $data->[$ix+1] ; + } + } + } + elsif (ref $data eq 'HASH') { + while (my ($id, $info) = each %$data) { + my $bad = validateExtraFieldPair([$id, $info], $lax); + return $bad if $bad ; - if ($whence == IO::Handle::SEEK_SET) { - $target = $position ; - } - elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) { - $target = $here + $position ; - } + $out .= $id . pack("v", length $info) . $info ; + } + } else { - croak *$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter"; + return ExtraFieldError("Not a scalar, array ref or hash ref") ; } - # 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 ; -} + $got->value('ExtraField' => $out); -sub fileno -{ - my $self = shift ; - return defined *$self->{FH} - ? *$self->{FH}->fileno() - : undef ; + return undef; } -sub _notAvailable +sub mkFinalTrailer { - my $name = shift ; - return sub { croak "$name Not Available: File opened only for output" ; } ; + return ''; } -*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. =head1 Functional Interface -A top-level function, C, is provided to carry out "one-shot" -compression between buffers and/or files. For finer control over the compression process, see the L section. +A top-level function, C, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L +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 expects -at least two parameters, C<$input> and C<$output>. + +C 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 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 and C