diff options
author | Rafael Garcia-Suarez <rgarciasuarez@gmail.com> | 2005-10-05 15:53:34 +0000 |
---|---|---|
committer | Rafael Garcia-Suarez <rgarciasuarez@gmail.com> | 2005-10-05 15:53:34 +0000 |
commit | 642e522ca519399524c3fc05cc7ff04ae62b068a (patch) | |
tree | 86d0b60756f5f2061d5781a7797e2013ea1bf011 /ext/Compress/Zlib | |
parent | bb275e7208fde6cd3835f1057d07fa69e22b40a4 (diff) | |
download | perl-642e522ca519399524c3fc05cc7ff04ae62b068a.tar.gz |
Upgrade to Compress::Zlib 2.000_05
p4raw-id: //depot/perl@25695
Diffstat (limited to 'ext/Compress/Zlib')
59 files changed, 28994 insertions, 3542 deletions
diff --git a/ext/Compress/Zlib/ANNOUNCE b/ext/Compress/Zlib/ANNOUNCE deleted file mode 100644 index 5bb34cd5df..0000000000 --- a/ext/Compress/Zlib/ANNOUNCE +++ /dev/null @@ -1,51 +0,0 @@ - Compress::Zlib - 1.00 - -Announcing release 1.00 of Compress::Zlib (formerly known as Zip -in the module list). - -What is Compress::Zlib? -======================= - -Compress::Zlib is a Perl external module which provides an interface to -the info-zip zlib compression library. zlib is a general purpose -compression library. - -Some of the features provided by Compress::Zlib include: - - * in-memory compression and decompression - * read and write gzip (.gz) files directly. - -By way of an example here is a small script which reads gzipped files -and writes the unzipped output to standard output. - - - use Compress::Zlib ; - - die "Usage: gzcat file...\n" - unless @ARGV ; - - foreach $file (@ARGV) { - $gz = gzopen($file, "rb") - or die "Cannot open $file: $gzerrno\n" ; - - print $buffer while $gz->gzread($buffer) > 0 ; - - die "Error reading from $file: $gzerrno\n" if $gzerrno ; - - $gz->gzclose() ; - } - - -Availability -============ - -The latest copy of Compress::ZLib is available on CPAN - - http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz - -and zlib is available at - - http://www.gzip.org/zlib/ - - -Paul Marquess diff --git a/ext/Compress/Zlib/Changes b/ext/Compress/Zlib/Changes index aa9bcc0c55..93ddaeb6ab 100644 --- a/ext/Compress/Zlib/Changes +++ b/ext/Compress/Zlib/Changes @@ -1,13 +1,44 @@ CHANGES ------- - 1.40 - 23 September 2005 + 2.000_05 4 October 2005 - * Fixed failure of 03examples.t for some windows systems. + * Renamed IO::* to IO::Compress::* & IO::Uncompress::* - 1.39 - 15 September 2005 + 2.000_04 23 September 2005 - * Fixed dTHX macro for 5.00503 on FreeBSD + * Fixed some more non-portable test that were failing on VMS. + + * fixed problem where error messages in the oneshot interface were + getting lost. + + 2.000_03 12 September 2005 + + * Fixed some non-portable test that were failing on VMS. + + * Fixed export of zlib constants from the IO::* classes + + 2.000_02 6 September 2005 + + * Split Append mode into Append and Merge + + * Fixed typos in the documentation. + + * Added pod/FAQ.pod + + * Added libscan to Makefile.PL + + * Added InputLength for IO::Gunzip et al + + 2.000_01 22 August 2005 + + * Fixed VERSION in Compress::Gzip::Constants + + * Removed Compress::Gzip::Info from the distribution. + + 2.000_00 21 August 2005 + + * First Beta relase of Compress::zlib rewrite. 1.38 - 6 September 2005 @@ -92,7 +123,7 @@ CHANGES 1.31 - 29 October 2003 * Reinstated the creation of .bak files - $^I seems to need a - backup file on Windows. For OpenVMS, the extension _bak is used. + backup file on Windows. For OpenVMS, the extenstion _bak is used. 1.30 - 28 October 2003 @@ -153,40 +184,20 @@ CHANGES variable to config.in to flag an old version of zlib. Split out the tests for gzsetparams into t/05gzsetp.t - 1.17 - 22 October 2002 + 1.17 - 23 May 2002 * Moved the test to check the versions of libz & zlib.h into a separate file and added troubleshooting notes to README. * In gzopen, only attempt to call "tell" for normal files. + * Fixed to work in taint mode. + * Broke changes out of README into Changes file. * Replaced internal use of Z_PARTIAL_FLUSH symbol with Z_SYNC_FLUSH. zlib.h says /* will be removed, use Z_SYNC_FLUSH instead */ - * Added support for zlib functions inflateSync and deflateParams. - - * Added support for zlib functions gzeof and gzsetparams. - - * Added support for access to adler, total_in & total_out - - * The compress function can now take an optional parameter that - allows the compression level to be specified. This mirrors the - compress2 function available in zlib. - - * memGzip doesn't work properly with perl 5.8.0 when it is given - UTF-8 data. Bug spotted by Andreas J. Koenig. - - * Added note about Linux zlib-devel RPM to README. - - * Fixed recursive build problem on win32 machines. - - * Fixed problem with the test harness on Mac OS X. - Thanks to Carl Johan Berglund for reporting the problem and - helping track it down. - - 1.16 - 13 December 2001 * Fixed bug in Makefile.PL that stopped "perl Makefile.PL PREFIX=..." @@ -209,7 +220,7 @@ CHANGES 1.13 - 31st June 2001 - * Make sure config.in is consistent when released. + * Make sure config.in is consistant when released. 1.12 - 28th April 2001 diff --git a/ext/Compress/Zlib/Makefile.PL b/ext/Compress/Zlib/Makefile.PL index eea4402e7c..108843670d 100755 --- a/ext/Compress/Zlib/Makefile.PL +++ b/ext/Compress/Zlib/Makefile.PL @@ -4,7 +4,7 @@ use strict ; require 5.004 ; use ExtUtils::MakeMaker 5.16 ; -use Config ; +use Config qw(%Config) ; use File::Copy ; BEGIN @@ -22,16 +22,14 @@ my $ZLIB_LIB ; my $ZLIB_INCLUDE ; my $BUILD_ZLIB = 0 ; my $OLD_ZLIB = '' ; -my $EXTRA_DEFINE = ''; -my $WALL = ''; -#$WALL = ' -Wall '; +my $WALL = '' ; +my $GZIP_OS_CODE = -1 ; -unless($ENV{PERL_CORE}) { - $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV; -} +#$WALL = ' -pedantic ' if $Config{'cc'} =~ /gcc/ ; +$WALL = ' -Wall ' if $Config{'cc'} =~ /gcc/ ; # 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} and not $ENV{PERL_CORE}) +if ($^O =~ /cygwin/i and not $ENV{PERL_MM_USE_DEFAULT}) { print <<EOM ; @@ -66,20 +64,30 @@ EOM ParseCONFIG() ; -my @files = ('Zlib.pm', glob("t/*.t"), grep(!/\.bak$/, glob("examples/*"))) ; -UpDowngrade(@files) unless $ENV{PERL_CORE} ; +my @files = ('Zlib.pm', 't/ZlibTestUtils.pm', + glob("t/*.t"), + glob("lib/IO/Compress/*.pm"), + glob("lib/IO/Uncompress/*.pm"), + glob("lib/Compress/Zlib/*.pm"), + glob("lib/Compress/Gzip/*.pm"), + glob("lib/File/*.pm"), + grep(!/\.bak$/, glob("examples/*"))) ; + +UpDowngrade(@files) unless $ENV{PERL_CORE}; WriteMakefile( NAME => 'Compress::Zlib', - VERSION_FROM => 'Zlib.pm', + VERSION_FROM => 'Zlib.pm', INC => "-I$ZLIB_INCLUDE" , - DEFINE => "$OLD_ZLIB $WALL $EXTRA_DEFINE" , - XS => { 'Zlib.xs' => 'Zlib.c' }, + DEFINE => "$OLD_ZLIB $WALL -DGZIP_OS_CODE=$GZIP_OS_CODE" , + XS => { 'Zlib.xs' => 'Zlib.c' }, + 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', SUFFIX => 'gz', - DIST_DEFAULT => 'MyDoubleCheck Downgrade tardist', + DIST_DEFAULT => 'MyDoubleCheck downgrade tardist', }, ($BUILD_ZLIB ? zlib_files($ZLIB_LIB) @@ -103,6 +111,7 @@ my @names = qw( Z_BEST_COMPRESSION Z_BEST_SPEED Z_BINARY + Z_BLOCK Z_BUF_ERROR Z_DATA_ERROR Z_DEFAULT_COMPRESSION @@ -111,6 +120,7 @@ my @names = qw( Z_ERRNO Z_FILTERED Z_FINISH + Z_FIXED Z_FULL_FLUSH Z_HUFFMAN_ONLY Z_MEM_ERROR @@ -120,12 +130,15 @@ my @names = qw( Z_NULL Z_OK Z_PARTIAL_FLUSH + Z_RLE Z_STREAM_END Z_STREAM_ERROR Z_SYNC_FLUSH Z_UNKNOWN Z_VERSION_ERROR + ); + #ZLIB_VERNUM if (eval {require ExtUtils::Constant; 1}) { # Check the constants above all appear in @EXPORT in Zlib.pm @@ -162,38 +175,40 @@ if (eval {require ExtUtils::Constant; 1}) { ); } else { - copy ('fallback.h', 'constants.h') - or die "Can't copy fallback.h to constants.h: $!"; - copy ('fallback.xs', 'constants.xs') - or die "Can't copy fallback.xs to constants.xs: $!"; + foreach my $name (qw( constants.h constants.xs )) + { + my $from = catfile('fallback', $name); + copy ($from, $name) + or die "Can't copy $from to $name: $!"; + } } sub MY::libscan { - my $self = shift ; - my $path = shift ; + my $self = shift; + my $path = shift; return undef - if $path =~ /(~|\.bak|_bak)$/ || - $path =~ /^\..*\.swp$/ ; + if $path =~ /(~|\.bak|_bak)$/ || + $path =~ /\..*\.swp$/ ; - return $path; + return $path; } - sub MY::postamble { my $postamble = <<'EOM'; -Downgrade: +downgrade: @echo Downgrading. perl Makefile.PL -downgrade MyDoubleCheck: @echo Checking config.in is setup for a release - @(grep '^LIB *= *./zlib' config.in && \ - grep '^INCLUDE *= *./zlib' config.in && \ + @(grep '^LIB *= *./zlib-src' config.in && \ + grep '^INCLUDE *= *./zlib-src' config.in && \ grep '^OLD_ZLIB *= *False' config.in && \ + grep '^GZIP_OS_CODE *= *AUTO_DETECT' config.in && \ grep '^BUILD_ZLIB *= *True' config.in) >/dev/null || \ (echo config.in needs fixing ; exit 1) @echo config.in is ok @@ -206,6 +221,39 @@ MyTrebleCheck: (echo found unexpected $$^W ; exit 1) @echo All is ok. +longtest: + @echo Running test suite with Devel::Cover + $(MAKE) test COMPRESS_ZLIB_RUN_ALL=1 + +cover: + @echo Running test suite with Devel::Cover + HARNESS_PERL_SWITCHES=-MDevel::Cover $(MAKE) test + +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 + +EOM + + $postamble .= <<'EOM' if $^O eq 'linux' ; + +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 + EOM return $postamble; @@ -217,7 +265,7 @@ sub ParseCONFIG my ($k, $v) ; my @badkey = () ; my %Info = () ; - my @Options = qw( INCLUDE LIB BUILD_ZLIB OLD_ZLIB ) ; + my @Options = qw( INCLUDE LIB BUILD_ZLIB OLD_ZLIB GZIP_OS_CODE ) ; my %ValidOption = map {$_, 1} @Options ; my %Parsed = %ValidOption ; my $CONFIG = 'config.in' ; @@ -258,8 +306,6 @@ sub ParseCONFIG $ZLIB_LIB = VMS::Filespec::vmspath($ZLIB_LIB); } - $EXTRA_DEFINE = $ENV{EXTRA_DEFINE} if defined $ENV{EXTRA_DEFINE}; - my $y = $ENV{'OLD_ZLIB'} || $Info{'OLD_ZLIB'} ; $OLD_ZLIB = '-DOLD_ZLIB' if $y and $y =~ /^yes|on|true|1$/i; @@ -283,18 +329,33 @@ sub ParseCONFIG unless -e catfile($ZLIB_LIB, 'zlib.h') ; - # check Makefile.zlib has been copied to ZLIB_LIB - #copy 'Makefile.zlib', catfile($ZLIB_LIB, 'Makefile.PL') || - #die "Could not copy Makefile.zlib to " . catfile($ZLIB_LIB, 'Makefile.PL') . ": $!\n" ; - #print "Created a Makefile.PL for zlib\n" ; - # write the Makefile print "Building Zlib enabled\n" ; } + $GZIP_OS_CODE = defined $ENV{'GZIP_OS_CODE'} + ? $ENV{'GZIP_OS_CODE'} + : $Info{'GZIP_OS_CODE'} ; + + die "GZIP_OS_CODE not 'AUTO_DETECT' or a number between 0 and 255\n" + unless uc $GZIP_OS_CODE eq 'AUTO_DETECT' + || ( $GZIP_OS_CODE =~ /^(\d+)$/ && $1 >= 0 && $1 <= 255) ; + + if (uc $GZIP_OS_CODE eq 'AUTO_DETECT') + { + print "Auto Detect Gzip OS Code..\n" ; + $GZIP_OS_CODE = getOSCode() ; + } + + my $name = getOSname($GZIP_OS_CODE); + print "Setting Gzip OS Code to $GZIP_OS_CODE [$name]\n" ; + print <<EOM if 0 ; - INCLUDE [$ZLIB_INCLUDE] - LIB [$ZLIB_LIB] + INCLUDE [$ZLIB_INCLUDE] + LIB [$ZLIB_LIB] + GZIP_OS_CODE [$GZIP_OS_CODE] + OLD_ZLIB [$OLD_ZLIB] + BUILD_ZLIB [$BUILD_ZLIB] EOM @@ -306,7 +367,7 @@ sub UpDowngrade { my @files = @_ ; - # our is stable from 5.6.0 onward + # our and use bytes/utf8 is stable from 5.6.0 onward # warnings is stable from 5.6.1 onward # Note: this code assumes that each statement it modifies is not @@ -344,6 +405,10 @@ sub UpDowngrade my $vars = join ' ', split /\s*,\s*/, $2; $_ = "${indent}use vars qw($vars);\n"; } + elsif ( /^(\s*)((use|no)\s+(bytes|utf8)\s*;.*)$/) + { + $_ = "$1# $2\n"; + } }; } elsif ($] >= 5.006000 || $upgrade) { @@ -353,6 +418,10 @@ sub UpDowngrade my $vars = join ', ', split ' ', $2; $_ = "${indent}our ($vars);\n"; } + elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/) + { + $_ = "$1$2\n"; + } }; } @@ -378,6 +447,8 @@ sub doUpDown my $our_sub = shift; my $warn_sub = shift; + return if -d $_[0]; + local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak"; local (@ARGV) = shift; @@ -408,23 +479,23 @@ sub zlib_files # zlib 1.2.0 or greater # @h_files = qw(crc32.h inffast.h inflate.h trees.h zconf.in.h - zutil.h deflate.h inffixed.h inftrees.h zconf.h - zlib.h + zutil.h deflate.h inffixed.h inftrees.h zconf.h + zlib.h ); @c_files = qw(adler32 crc32 infback inflate uncompr - compress deflate gzio inffast inftrees - trees zutil + compress deflate inffast inftrees + trees zutil ); } else { # zlib 1.1.x @h_files = qw(deflate.h infcodes.h inftrees.h zconf.h zutil.h - infblock.h inffast.h infutil.h zlib.h + infblock.h inffast.h infutil.h zlib.h ); - @c_files = qw(adler32 compress crc32 gzio uncompr - deflate trees zutil inflate infblock - inftrees infcodes infutil inffast + @c_files = qw(adler32 compress crc32 uncompr + deflate trees zutil inflate infblock + inftrees infcodes infutil inffast ); } @@ -446,5 +517,62 @@ sub zlib_files } + +my @GZIP_OS_Names ; +my %OSnames ; + +BEGIN +{ + @GZIP_OS_Names = ( + [ '' => 0, 'MS-DOS' ], + [ 'amigaos' => 1, 'Amiga' ], + [ 'VMS' => 2, 'VMS' ], + [ '' => 3, 'Unix/Default' ], + [ '' => 4, 'VM/CMS' ], + [ '' => 5, 'Atari TOS' ], + [ 'os2' => 6, 'HPFS (OS/2, NT)' ], + [ 'MacOS' => 7, 'Macintosh' ], + [ '' => 8, 'Z-System' ], + [ '' => 9, 'CP/M' ], + [ '' => 10, 'TOPS-20' ], + [ '' => 11, 'NTFS (NT)' ], + [ '' => 12, 'SMS QDOS' ], + [ '' => 13, 'Acorn RISCOS' ], + [ 'MSWin32' => 14, 'VFAT file system (Win95, NT)' ], + [ '' => 15, 'MVS' ], + [ 'beos' => 16, 'BeOS' ], + [ '' => 17, 'Tandem/NSK' ], + [ '' => 18, 'THEOS' ], + [ '' => 255, 'Unknown OS' ], + ); + + %OSnames = map { $$_[1] => $$_[2] } + @GZIP_OS_Names ; +} + +sub getOSCode +{ + my $default = 3 ; # Unix is the default + + my $uname = $^O; + + for my $h (@GZIP_OS_Names) + { + my ($pattern, $code, $name) = @$h; + + return $code + if $pattern && $uname eq $pattern ; + } + + return $default ; +} + +sub getOSname +{ + my $code = shift ; + + return $OSnames{$code} || 'Unknown OS' ; +} + # end of file Makefile.PL diff --git a/ext/Compress/Zlib/README b/ext/Compress/Zlib/README index 086a72b5b8..efeb32f6d6 100644 --- a/ext/Compress/Zlib/README +++ b/ext/Compress/Zlib/README @@ -1,20 +1,29 @@ + Compress::Zlib - Version 1.40 + Version 2.000_05 + + 4 Oct 2005 - 23 September 2005 + Copyright (c) 1995-2005 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. - Copyright (c) 1995-2005 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. - The directory zlib-src contains a subset of the source files copied - directly from zlib version 1.2.3. These files are Copyright(C) - 1995-2005 Jean-loup Gailly and Mark Adler. - Full source for the zlib library is available at + The directory zlib-src contains a subset of the + source files copied directly from zlib version 1.2.3. + These files are Copyright(C) 1995-2005 + Jean-loup Gailly and Mark Adler. + Full source for the zlib library is available at http://www.zlib.org + WARNING + THIS IS BETA CODE. + + DO NOT use in production code. + Please report any problems. + DESCRIPTION ----------- @@ -29,6 +38,8 @@ module below once you have installed this one. http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz + + PREREQUISITES ------------- @@ -90,13 +101,11 @@ library is used: 3. Use a pre-built zlib library. Note that if you intend to use either Option 2 or 3, you need to have -zlib version 1.0.6 or better. Although this module can build with old -versions of zlib, it is strongly recommended that you use the most recent -version of zlib available. +zlib version 1.0.5 or better. The contents of the file config.in are used to control which of the -three options is actually used. This file is used during the +three options is actually used. This file is read during the perl Makefile.PL @@ -111,10 +120,11 @@ before building this module. For option 1, edit the file config.in and set the variables in it as follows: - BUILD_ZLIB = True - INCLUDE = ./zlib-src - LIB = ./zlib-src - OLD_ZLIB = False + BUILD_ZLIB = True + INCLUDE = ./zlib-src + LIB = ./zlib-src + OLD_ZLIB = False + GZIP_OS_CODE = AUTO_DETECT Option 2 @@ -122,17 +132,18 @@ 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.1.4, it will create a - directory called zlib-1.1.4. + 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.1.4, change the INCLUDE and LIB variables + you have fetched isn't 1.2.3, change the INCLUDE and LIB variables appropriately): - BUILD_ZLIB = True - INCLUDE = ./zlib-1.1.4 - LIB = ./zlib-1.1.4 - OLD_ZLIB = False + BUILD_ZLIB = True + INCLUDE = ./zlib-1.2.3 + LIB = ./zlib-1.2.3 + OLD_ZLIB = False + GZIP_OS_CODE = AUTO_DETECT Option 3 @@ -148,21 +159,53 @@ before building this module. Secondly, find the directory where the file zlib.h is stored. Now set the INCLUDE variable in the config.in file to that directory. - Next set BUILD_ZLIB to False + Next set BUILD_ZLIB to False. Finally, if you are running zlib 1.0.5 or older, set the OLD_ZLIB variable to True. Otherwise set it to False. As an example, if the zlib library on your system is in /usr/local/lib, - zlib.h is in /usr/local/include and zlib is more older than version + zlib.h is in /usr/local/include and zlib is more recent than version 1.0.5, the variables in config.in should be set as follows: - BUILD_ZLIB = False - INCLUDE = /usr/local/include - LIB = /usr/local/lib - OLD_ZLIB = True + BUILD_ZLIB = False + INCLUDE = /usr/local/include + LIB = /usr/local/lib + OLD_ZLIB = False + GZIP_OS_CODE = AUTO_DETECT +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. + +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 + + 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 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. TROUBLESHOOTING @@ -201,7 +244,6 @@ Try removing the one you don't want to use and rebuild. - Solaris build fails with "language optional software package not installed" --------------------------------------------------------------------------- @@ -222,7 +264,7 @@ lived in /usr/ucb. To continue with building this module, you need to get a C compiler, or tell Perl where your C compiler is, if you already have one. -Assuming you have now got a C compiler, what you do next will be dependant +Assuming you have now got a C compiler, what you do next will be dependent on what C compiler you have installed. If you have just installed Sun's C compiler, you shouldn't have to do anything. Just try rebuilding this module. @@ -273,6 +315,22 @@ The solution is either: mileage may vary. +The t/17isize Test Suite +------------------------ + +This test suite checks that Compress::Zlib can cope with gzip files +that are larger than 2^32 bytes. + +By default these test are NOT run when you do a "make test". If you +really want to run them, you need to execute "make longtest". + +Be warned though -- this test suite can take hours to run on a slow box. + +Also, due to the way the tests are constructed, some architectures will +run out of memory during these test. This should not be considered a bug +in the Compress::Zlib module. + + HP-UX Notes ----------- @@ -333,25 +391,6 @@ instructions given at the start of this file. -Mac OX X Notes --------------- - -Some versions of Mac OS X are failing a number of the tests in the -06gzdopen.t test harness. - -The functionality being exercised in these tests is checking that it is -possible to call gzopen with an existing Perl filehandle instead of a -filename. For some reason it does not seem possible to extract a -numeric file descriptor (using fileno) from a FILE* and then make use -of it. - -If you happen to now how to fix for this, I would like to hear from you. - -In the meantime, a workaround that has been reported to me is to use fink, -available at http://fink.sourceforge.net - - - FEEDBACK -------- diff --git a/ext/Compress/Zlib/Zlib.pm b/ext/Compress/Zlib/Zlib.pm index f6e48ace80..8ba529e239 100644 --- a/ext/Compress/Zlib/Zlib.pm +++ b/ext/Compress/Zlib/Zlib.pm @@ -1,12 +1,3 @@ -# File : Zlib.pm -# Author : Paul Marquess -# Created : 23 September 2005 -# Version : 1.40 -# -# Copyright (c) 1995-2005 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. -# package Compress::Zlib; @@ -15,72 +6,73 @@ require Exporter; use AutoLoader; use Carp ; use IO::Handle ; +use Scalar::Util qw(dualvar); + +use Compress::Zlib::Common; +use Compress::Zlib::ParseParameters; use strict ; use warnings ; -our ($VERSION, @ISA, @EXPORT, $AUTOLOAD); -our ($deflateDefault, $deflateParamsDefault, $inflateDefault); +use bytes ; +our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD); -$VERSION = "1.40" ; +$VERSION = '2.000_05'; +$XS_VERSION = $VERSION; +$VERSION = eval $VERSION; @ISA = qw(Exporter); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. @EXPORT = qw( - deflateInit - inflateInit - - compress - uncompress + deflateInit inflateInit - gzip gunzip + compress uncompress - gzopen - $gzerrno + gzopen $gzerrno - adler32 - crc32 + adler32 crc32 - ZLIB_VERSION - ZLIB_VERNUM + ZLIB_VERSION + ZLIB_VERNUM - DEF_WBITS - OS_CODE + DEF_WBITS + OS_CODE MAX_MEM_LEVEL - MAX_WBITS - - Z_ASCII - Z_BEST_COMPRESSION - Z_BEST_SPEED - Z_BINARY - Z_BUF_ERROR - Z_DATA_ERROR - Z_DEFAULT_COMPRESSION - Z_DEFAULT_STRATEGY + MAX_WBITS + + Z_ASCII + Z_BEST_COMPRESSION + Z_BEST_SPEED + Z_BINARY + Z_BLOCK + Z_BUF_ERROR + Z_DATA_ERROR + Z_DEFAULT_COMPRESSION + Z_DEFAULT_STRATEGY Z_DEFLATED - Z_ERRNO - Z_FILTERED - Z_FINISH - Z_FULL_FLUSH - Z_HUFFMAN_ONLY - Z_MEM_ERROR - Z_NEED_DICT - Z_NO_COMPRESSION - Z_NO_FLUSH - Z_NULL - Z_OK - Z_PARTIAL_FLUSH - Z_STREAM_END - Z_STREAM_ERROR - Z_SYNC_FLUSH - Z_UNKNOWN - Z_VERSION_ERROR + Z_ERRNO + Z_FILTERED + Z_FIXED + Z_FINISH + Z_FULL_FLUSH + Z_HUFFMAN_ONLY + Z_MEM_ERROR + Z_NEED_DICT + Z_NO_COMPRESSION + Z_NO_FLUSH + Z_NULL + Z_OK + Z_PARTIAL_FLUSH + Z_RLE + Z_STREAM_END + Z_STREAM_ERROR + Z_SYNC_FLUSH + Z_UNKNOWN + Z_VERSION_ERROR ); - - sub AUTOLOAD { my($constname); ($constname = $AUTOLOAD) =~ s/.*:://; @@ -91,174 +83,416 @@ sub AUTOLOAD { goto &{$AUTOLOAD}; } +use constant FLAG_APPEND => 1 ; +use constant FLAG_CRC => 2 ; +use constant FLAG_ADLER => 4 ; +use constant FLAG_CONSUME_INPUT => 8 ; + eval { require XSLoader; - XSLoader::load('Compress::Zlib', $VERSION); -} or do { + XSLoader::load('Compress::Zlib', $XS_VERSION); + 1; +} +or do { require DynaLoader; local @ISA = qw(DynaLoader); - bootstrap Compress::Zlib $VERSION ; -} ; - + bootstrap Compress::Zlib $XS_VERSION ; +}; + # Preloaded methods go here. -sub isaFilehandle($) +require IO::Compress::Gzip; +require IO::Uncompress::Gunzip; + +our (@my_z_errmsg); + +@my_z_errmsg = ( + "need dictionary", # Z_NEED_DICT 2 + "stream end", # Z_STREAM_END 1 + "", # Z_OK 0 + "file error", # Z_ERRNO (-1) + "stream error", # Z_STREAM_ERROR (-2) + "data error", # Z_DATA_ERROR (-3) + "insufficient memory", # Z_MEM_ERROR (-4) + "buffer error", # Z_BUF_ERROR (-5) + "incompatible version",# Z_VERSION_ERROR(-6) + ); + + +sub _set_gzerr { - my $fh = shift ; + my $value = shift ; - return ((UNIVERSAL::isa($fh,'GLOB') or UNIVERSAL::isa(\$fh,'GLOB')) - and defined fileno($fh) ) + if ($value == 0) { + $Compress::Zlib::gzerrno = 0 ; + } + elsif ($value == Z_ERRNO() || $value > 2) { + $Compress::Zlib::gzerrno = $! ; + } + else { + $Compress::Zlib::gzerrno = dualvar($value+0, $my_z_errmsg[2 - $value]); + } + return $value ; } -sub isaFilename($) +sub _save_gzerr { - my $name = shift ; + my $gz = shift ; + my $test_eof = shift ; + + my $value = $gz->errorNo() || 0 ; + + if ($test_eof) { + #my $gz = $self->[0] ; + # gzread uses Z_STREAM_END to denote a successful end + $value = Z_STREAM_END() if $gz->eof() && $value == 0 ; + } - return (! ref $name and UNIVERSAL::isa(\$name, 'SCALAR')) ; + _set_gzerr($value) ; } sub gzopen($$) { my ($file, $mode) = @_ ; - - if (isaFilehandle $file) { - IO::Handle::flush($file) ; - my $offset = tell($file) ; - gzdopen_(fileno($file), $mode, $offset) ; - } - elsif (isaFilename $file) { - gzopen_($file, $mode) + + my $gz ; + my %defOpts = (Level => Z_DEFAULT_COMPRESSION(), + Strategy => Z_DEFAULT_STRATEGY(), + ); + + my $writing ; + $writing = ! ($mode =~ /r/i) ; + $writing = ($mode =~ /[wa]/i) ; + + $defOpts{Level} = $1 if $mode =~ /(\d)/; + $defOpts{Strategy} = Z_FILTERED() if $mode =~ /f/i; + $defOpts{Strategy} = Z_HUFFMAN_ONLY() if $mode =~ /h/i; + + my $infDef = $writing ? 'deflate' : 'inflate'; + my @params = () ; + + croak "gzopen: file parameter is not a filehandle or filename" + unless isaFilehandle $file || isaFilename $file ; + + return undef unless $mode =~ /[rwa]/i ; + + _set_gzerr(0) ; + + if ($writing) { + $gz = new IO::Compress::Gzip($file, Minimal => 1, AutoClose => 1, %defOpts) + or $Compress::Zlib::gzerrno = $IO::Compress::Gzip::GzipError; } else { - croak "gzopen: file parameter is not a filehandle or filename" + $gz = new IO::Uncompress::Gunzip($file, Append => 0, AutoClose => 1, Strict => 0) + or $Compress::Zlib::gzerrno = $IO::Uncompress::Gunzip::GunzipError; } + + return undef + if ! defined $gz ; + + bless [$gz, $infDef], 'Compress::Zlib::gzFile'; } -sub ParseParameters($@) +sub Compress::Zlib::gzFile::gzread { - my ($default, @rest) = @_ ; - my (%got) = %$default ; - my (@Bad) ; - my ($key, $value) ; - my $sub = (caller(1))[3] ; - my %options = () ; + my $self = shift ; - # allow the options to be passed as a hash reference or - # as the complete hash. - if (@rest == 1) { + return _set_gzerr(Z_STREAM_ERROR()) + if $self->[1] ne 'inflate'; - croak "$sub: parameter is not a reference to a hash" - if ref $rest[0] ne "HASH" ; + return 0 if $self->gzeof(); - %options = %{ $rest[0] } ; - } - elsif (@rest >= 2) { - my $count = @rest; - croak "$sub: Expected even number of parameters, got $count" - if @rest % 2 != 0 ; - %options = @rest ; - } + my $gz = $self->[0] ; + my $status = $gz->read($_[0], defined $_[1] ? $_[1] : 4096) ; + $_[0] = "" if ! defined $_[0] ; + _save_gzerr($gz, 1); + return $status ; +} - while (($key, $value) = each %options) - { - $key =~ s/^-// ; +sub Compress::Zlib::gzFile::gzreadline +{ + my $self = shift ; - if (exists $default->{$key}) - { $got{$key} = $value } - else - { push (@Bad, $key) } - } - - if (@Bad) { - my ($bad) = join(", ", @Bad) ; - croak "unknown key value(s) @Bad" ; + my $gz = $self->[0] ; + $_[0] = $gz->getline() ; + _save_gzerr($gz, 1); + return defined $_[0] ? length $_[0] : 0 ; +} + +sub Compress::Zlib::gzFile::gzwrite +{ + my $self = shift ; + my $gz = $self->[0] ; + + return _set_gzerr(Z_STREAM_ERROR()) + if $self->[1] ne 'deflate'; + + my $status = $gz->write($_[0]) ; + _save_gzerr($gz); + return $status ; +} + +sub Compress::Zlib::gzFile::gztell +{ + my $self = shift ; + my $gz = $self->[0] ; + my $status = $gz->tell() ; + _save_gzerr($gz); + return $status ; +} + +sub Compress::Zlib::gzFile::gzseek +{ + my $self = shift ; + my $offset = shift ; + my $whence = shift ; + + my $gz = $self->[0] ; + my $status ; + eval { $status = $gz->seek($offset, $whence) ; }; + if ($@) + { + my $error = $@; + $error =~ s/^.*: /gzseek: /; + $error =~ s/ at .* line \d+\s*$//; + croak $error; } + _save_gzerr($gz); + return $status ; +} + +sub Compress::Zlib::gzFile::gzflush +{ + my $self = shift ; + my $f = shift ; - return \%got ; + my $gz = $self->[0] ; + my $status = $gz->flush($f) ; + _save_gzerr($gz); + return $status ; } -$deflateDefault = { - 'Level' => Z_DEFAULT_COMPRESSION(), - 'Method' => Z_DEFLATED(), - 'WindowBits' => MAX_WBITS(), - 'MemLevel' => MAX_MEM_LEVEL(), - 'Strategy' => Z_DEFAULT_STRATEGY(), - 'Bufsize' => 4096, - 'Dictionary' => "", - } ; - -$deflateParamsDefault = { - 'Level' => undef, - 'Strategy' => undef, - 'Bufsize' => undef, - } ; - -$inflateDefault = { - 'WindowBits' => MAX_WBITS(), - 'Bufsize' => 4096, - 'Dictionary' => "", - } ; +sub Compress::Zlib::gzFile::gzclose +{ + my $self = shift ; + my $gz = $self->[0] ; + my $status = $gz->close() ; + _save_gzerr($gz); + return ! $status ; +} -sub deflateInit(@) +sub Compress::Zlib::gzFile::gzeof { - my ($got) = ParseParameters($deflateDefault, @_) ; - no warnings; - croak "deflateInit: Bufsize must be >= 1, you specified $got->{Bufsize}" - unless $got->{Bufsize} >= 1; - _deflateInit($got->{Level}, $got->{Method}, $got->{WindowBits}, - $got->{MemLevel}, $got->{Strategy}, $got->{Bufsize}, - $got->{Dictionary}) ; - + my $self = shift ; + my $gz = $self->[0] ; + + return 0 + if $self->[1] ne 'inflate'; + + my $status = $gz->eof() ; + _save_gzerr($gz); + return $status ; } -sub inflateInit(@) +sub Compress::Zlib::gzFile::gzsetparams +{ + my $self = shift ; + croak "Usage: Compress::Zlib::gzFile::gzsetparams(file, level, strategy)" + unless @_ eq 2 ; + + my $gz = $self->[0] ; + my $level = shift ; + my $strategy = shift; + + return _set_gzerr(Z_STREAM_ERROR()) + if $self->[1] ne 'deflate'; + + my $status = *$gz->{Deflate}->deflateParams(-Level => $level, + -Strategy => $strategy); + _save_gzerr($gz); + return $status ; +} + +sub Compress::Zlib::gzFile::gzerror +{ + my $self = shift ; + my $gz = $self->[0] ; + + return $Compress::Zlib::gzerrno ; +} + +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], + + '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, ""], + }, @_) ; + + + croak "Compress::Zlib::Deflate::new: Bufsize must be >= 1, you specified " . + $got->value('Bufsize') + unless $got->value('Bufsize') >= 1; + + my $flags = 0 ; + $flags |= FLAG_APPEND if $got->value('AppendOutput') ; + $flags |= FLAG_CRC if $got->value('CRC32') ; + $flags |= FLAG_ADLER if $got->value('ADLER32') ; + + _deflateInit($flags, + $got->value('Level'), + $got->value('Method'), + $got->value('WindowBits'), + $got->value('MemLevel'), + $got->value('Strategy'), + $got->value('Bufsize'), + $got->value('Dictionary')) ; + +} + +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], + + 'WindowBits' => [Parse_signed, MAX_WBITS()], + 'Dictionary' => [Parse_any, ""], + }, @_) ; + + + croak "Compress::Zlib::Inflate::new: Bufsize must be >= 1, you specified " . + $got->value('Bufsize') + unless $got->value('Bufsize') >= 1; + + my $flags = 0 ; + $flags |= FLAG_APPEND if $got->value('AppendOutput') ; + $flags |= FLAG_CRC if $got->value('CRC32') ; + $flags |= FLAG_ADLER if $got->value('ADLER32') ; + $flags |= FLAG_CONSUME_INPUT if $got->value('ConsumeInput') ; + + _inflateInit($flags, $got->value('WindowBits'), $got->value('Bufsize'), + $got->value('Dictionary')) ; +} + +sub Compress::Zlib::InflateScan::new +{ + my $pkg = shift ; + my ($got) = ParseParameters(0, + { + 'CRC32' => [Parse_boolean, 0], + 'ADLER32' => [Parse_boolean, 0], + 'Bufsize' => [Parse_unsigned, 4096], + + 'WindowBits' => [Parse_signed, -MAX_WBITS()], + 'Dictionary' => [Parse_any, ""], + }, @_) ; + + + croak "Compress::Zlib::InflateScan::new: Bufsize must be >= 1, you specified " . + $got->value('Bufsize') + unless $got->value('Bufsize') >= 1; + + my $flags = 0 ; + #$flags |= FLAG_APPEND if $got->value('AppendOutput') ; + $flags |= FLAG_CRC if $got->value('CRC32') ; + $flags |= FLAG_ADLER if $got->value('ADLER32') ; + #$flags |= FLAG_CONSUME_INPUT if $got->value('ConsumeInput') ; + + _inflateScanInit($flags, $got->value('WindowBits'), $got->value('Bufsize'), + '') ; +} + +sub Compress::Zlib::inflateScanStream::createDeflateStream { - my ($got) = ParseParameters($inflateDefault, @_) ; - no warnings; - croak "inflateInit: Bufsize must be >= 1, you specified $got->{Bufsize}" - unless $got->{Bufsize} >= 1; - _inflateInit($got->{WindowBits}, $got->{Bufsize}, $got->{Dictionary}); + my $pkg = shift ; + my ($got) = ParseParameters(0, + { + 'AppendOutput' => [Parse_boolean, 0], + 'CRC32' => [Parse_boolean, 0], + 'ADLER32' => [Parse_boolean, 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()], + }, @_) ; + + croak "Compress::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified " . + $got->value('Bufsize') + unless $got->value('Bufsize') >= 1; + + my $flags = 0 ; + $flags |= FLAG_APPEND if $got->value('AppendOutput') ; + $flags |= FLAG_CRC if $got->value('CRC32') ; + $flags |= FLAG_ADLER if $got->value('ADLER32') ; + + $pkg->_createDeflateStream($flags, + $got->value('Level'), + $got->value('Method'), + $got->value('WindowBits'), + $got->value('MemLevel'), + $got->value('Strategy'), + $got->value('Bufsize'), + ) ; + } + sub Compress::Zlib::deflateStream::deflateParams { my $self = shift ; - my ($got) = ParseParameters($deflateParamsDefault, @_) ; - croak "deflateParams needs Level and/or Strategy" - unless defined $got->{Level} || defined $got->{Strategy}; - no warnings; - croak "deflateParams: Bufsize must be >= 1, you specified $got->{Bufsize}" - unless !defined $got->{Bufsize} || $got->{Bufsize} >= 1; + my ($got) = ParseParameters(0, { + 'Level' => [Parse_signed, undef], + 'Strategy' => [Parse_unsigned, undef], + 'Bufsize' => [Parse_unsigned, undef], + }, + @_) ; + + croak "Compress::Zlib::deflateParams needs Level and/or Strategy" + unless $got->parsed('Level') + $got->parsed('Strategy') + + $got->parsed('Bufsize'); + + croak "Compress::Zlib::Inflate::deflateParams: Bufsize must be >= 1, you specified " . + $got->value('Bufsize') + if $got->parsed('Bufsize') && $got->value('Bufsize') <= 1; my $flags = 0; - if (defined $got->{Level}) - { $flags |= 1 } - else - { $got->{Level} = 0 } - - if (defined $got->{Strategy}) - { $flags |= 2 } - else - { $got->{Strategy} = 0 } - - $got->{Bufsize} = 0 - if !defined $got->{Bufsize}; - - $self->_deflateParams($flags, $got->{Level}, $got->{Strategy}, - $got->{Bufsize}); - + $flags |= 1 if $got->parsed('Level') ; + $flags |= 2 if $got->parsed('Strategy') ; + $flags |= 4 if $got->parsed('Bufsize') ; + + $self->_deflateParams($flags, $got->value('Level'), + $got->value('Strategy'), $got->value('Bufsize')); + } sub compress($;$) { - my ($x, $output, $out, $err, $in) ; + my ($x, $output, $err, $in) =('', '', '', '') ; if (ref $_[0] ) { $in = $_[0] ; - croak "not a scalar reference" unless ref $in eq 'SCALAR' ; + croak "not a scalar reference" unless ref $in eq 'SCALAR' ; } else { $in = \$_[0] ; @@ -266,116 +500,277 @@ sub compress($;$) my $level = (@_ == 2 ? $_[1] : Z_DEFAULT_COMPRESSION() ); + $x = new Compress::Zlib::Deflate -AppendOutput => 1, -Level => $level + or return undef ; - if ( (($x, $err) = deflateInit(Level => $level))[1] == Z_OK()) { + $err = $x->deflate($in, $output) ; + return undef unless $err == Z_OK() ; - ($output, $err) = $x->deflate($in) ; - return undef unless $err == Z_OK() ; - - ($out, $err) = $x->flush() ; - return undef unless $err == Z_OK() ; + $err = $x->flush($output) ; + return undef unless $err == Z_OK() ; - return ($output . $out) ; - - } + return $output ; - return undef ; } - sub uncompress($) { - my ($x, $output, $err, $in) ; + my ($x, $output, $err, $in) =('', '', '', '') ; if (ref $_[0] ) { $in = $_[0] ; - croak "not a scalar reference" unless ref $in eq 'SCALAR' ; + croak "not a scalar reference" unless ref $in eq 'SCALAR' ; } else { $in = \$_[0] ; } - if ( (($x, $err) = inflateInit())[1] == Z_OK()) { + $x = new Compress::Zlib::Inflate -ConsumeInput => 0 or return undef ; - ($output, $err) = $x->__unc_inflate($in) ; - return undef unless $err == Z_STREAM_END() ; + $err = $x->inflate($in, $output) ; + return undef unless $err == Z_STREAM_END() ; - return $output ; - } + return $output ; +} + + +### This stuff is for backward compat. with Compress::Zlib 1.x + - return undef ; +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, ""], + }, @_ ) ; + + croak "Compress::Zlib::deflateInit: Bufsize must be >= 1, you specified " . + $got->value('Bufsize') + unless $got->value('Bufsize') >= 1; + + my (%obj) = () ; + + my $status = 0 ; + ($obj{def}, $status) = + _deflateInit(0, + $got->value('Level'), + $got->value('Method'), + $got->value('WindowBits'), + $got->value('MemLevel'), + $got->value('Strategy'), + $got->value('Bufsize'), + $got->value('Dictionary')) ; + + my $x = ($status == Z_OK() ? bless \%obj, "Zlib::OldDeflate" : undef) ; + return wantarray ? ($x, $status) : $x ; } + +sub inflateInit(@) +{ + my ($got) = ParseParameters(0, + { + 'Bufsize' => [Parse_unsigned, 4096], + 'WindowBits' => [Parse_signed, MAX_WBITS()], + 'Dictionary' => [Parse_any, ""], + }, @_) ; -# Constants -use constant MAGIC1 => 0x1f ; -use constant MAGIC2 => 0x8b ; -use constant OSCODE => 3 ; + croak "Compress::Zlib::inflateInit: Bufsize must be >= 1, you specified " . + $got->value('Bufsize') + unless $got->value('Bufsize') >= 1; -use constant FTEXT => 1 ; -use constant FHCRC => 2 ; -use constant FEXTRA => 4 ; -use constant FNAME => 8 ; -use constant FCOMMENT => 16 ; -use constant NULL => pack("C", 0) ; -use constant RESERVED => 0xE0 ; + my $status = 0 ; + my (%obj) = () ; + ($obj{def}, $status) = _inflateInit(FLAG_CONSUME_INPUT, + $got->value('WindowBits'), + $got->value('Bufsize'), + $got->value('Dictionary')) ; + + my $x = ($status == Z_OK() ? bless \%obj, "Zlib::OldInflate" : undef) ; + + wantarray ? ($x, $status) : $x ; +} + +package Zlib::OldDeflate ; + +sub deflate +{ + my $self = shift ; + my $output ; + #my (@rest) = @_ ; + + my $status = $self->{def}->deflate($_[0], $output) ; + + wantarray ? ($output, $status) : $output ; +} + +sub flush +{ + my $self = shift ; + my $output ; + my $flag = shift || Compress::Zlib::Z_FINISH(); + my $status = $self->{def}->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 ; + +sub inflate +{ + my $self = shift ; + my $output ; + my $status = $self->{def}->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; -use constant MIN_HDR_SIZE => 10 ; # minimum gzip header size - sub memGzip($) { - my $x = deflateInit( + my $x = new Compress::Zlib::Deflate( + -AppendOutput => 1, + -CRC32 => 1, + -ADLER32 => 0, -Level => Z_BEST_COMPRESSION(), - -WindowBits => - MAX_WBITS(), + -WindowBits => - MAX_WBITS(), ) or return undef ; # write a minimal gzip header - my(@m); - push @m, pack("C" . MIN_HDR_SIZE, - MAGIC1, MAGIC2, Z_DEFLATED(), 0,0,0,0,0,0, OSCODE) ; + my $output = GZIP_MINIMUM_HEADER ; # if the deflation buffer isn't a reference, make it one my $string = (ref $_[0] ? $_[0] : \$_[0]) ; - my ($output, $status) = $x->deflate($string) ; - push @m, $output ; + my $status = $x->deflate($string, \$output) ; $status == Z_OK() or return undef ; - ($output, $status) = $x->flush() ; - push @m, $output ; + $status = $x->flush(\$output) ; $status == Z_OK() or return undef ; - push @m, pack("V V", crc32($string), $x->total_in()); + return $output . pack("V V", $x->crc32(), $x->total_in()) ; - return join "", @m; } + sub _removeGzipHeader($) { my $string = shift ; return Z_DATA_ERROR() - if length($$string) < MIN_HDR_SIZE ; + if length($$string) < GZIP_MIN_HEADER_SIZE ; my ($magic1, $magic2, $method, $flags, $time, $xflags, $oscode) = unpack ('CCCCVCC', $$string); return Z_DATA_ERROR() - unless $magic1 == MAGIC1 and $magic2 == MAGIC2 and - $method == Z_DEFLATED() and !($flags & RESERVED()) ; - substr($$string, 0, MIN_HDR_SIZE) = '' ; + unless $magic1 == GZIP_ID1 and $magic2 == GZIP_ID2 and + $method == Z_DEFLATED() and !($flags & GZIP_FLG_RESERVED) ; + substr($$string, 0, GZIP_MIN_HEADER_SIZE) = '' ; # skip extra field - if ($flags & FEXTRA) + if ($flags & GZIP_FLG_FEXTRA) { return Z_DATA_ERROR() - if length($$string) < 2 ; + if length($$string) < GZIP_FEXTRA_HEADER_SIZE ; my ($extra_len) = unpack ('v', $$string); - $extra_len += 2; + $extra_len += GZIP_FEXTRA_HEADER_SIZE; return Z_DATA_ERROR() if length($$string) < $extra_len ; @@ -383,29 +778,29 @@ sub _removeGzipHeader($) } # skip orig name - if ($flags & FNAME) + if ($flags & GZIP_FLG_FNAME) { - my $name_end = index ($$string, NULL); + my $name_end = index ($$string, GZIP_NULL_BYTE); return Z_DATA_ERROR() if $name_end == -1 ; substr($$string, 0, $name_end + 1) = ''; } # skip comment - if ($flags & FCOMMENT) + if ($flags & GZIP_FLG_FCOMMENT) { - my $comment_end = index ($$string, NULL); + my $comment_end = index ($$string, GZIP_NULL_BYTE); return Z_DATA_ERROR() if $comment_end == -1 ; substr($$string, 0, $comment_end + 1) = ''; } # skip header crc - if ($flags & FHCRC) + if ($flags & GZIP_FLG_FHCRC) { return Z_DATA_ERROR() - if length ($$string) < 2 ; - substr($$string, 0, 2) = ''; + if length ($$string) < GZIP_FHCRC_SIZE ; + substr($$string, 0, GZIP_FHCRC_SIZE) = ''; } return Z_OK(); @@ -421,10 +816,13 @@ sub memGunzip($) or return undef; my $bufsize = length $$string > 4096 ? length $$string : 4096 ; - my $x = inflateInit( -WindowBits => - MAX_WBITS(), - -Bufsize => $bufsize) + my $x = new Compress::Zlib::Inflate({-WindowBits => - MAX_WBITS(), + -Bufsize => $bufsize}) + or return undef; - my ($output, $status) = $x->inflate($string); + + my $output = "" ; + my $status = $x->inflate($string, $output); return undef unless $status == Z_STREAM_END(); @@ -440,7 +838,6 @@ sub memGunzip($) { $$string = ''; } - return $output; } @@ -456,26 +853,35 @@ Compress::Zlib - Interface to zlib compression library =head1 SYNOPSIS - use Compress::Zlib ; + use Compress::Zlib 2 ; - ($d, $status) = deflateInit( [OPT] ) ; - ($out, $status) = $d->deflate($buffer) ; - $status = $d->deflateParams([OPT]) ; - ($out, $status) = $d->flush() ; + ($d, $status) = new Compress::Zlib::Deflate( [OPT] ) ; + $status = $d->deflate($input, $output) ; + $status = $d->flush($output [, $flush_type]) ; + $d->deflateParams(OPTS) ; + $d->deflateTune(OPTS) ; $d->dict_adler() ; + $d->crc32() ; + $d->adler32() ; $d->total_in() ; $d->total_out() ; $d->msg() ; + $d->get_Strategy(); + $d->get_Level(); + $d->get_BufSize(); - ($i, $status) = inflateInit( [OPT] ) ; - ($out, $status) = $i->inflate($buffer) ; - $status = $i->inflateSync($buffer) ; + ($i, $status) = new Compress::Zlib::Inflate( [OPT] ) ; + $status = $i->inflate($input, $output) ; + $status = $i->inflateSync($input) ; $i->dict_adler() ; + $d->crc32() ; + $d->adler32() ; $i->total_in() ; $i->total_out() ; $i->msg() ; + $d->get_BufSize(); - $dest = compress($source, [$level]) ; + $dest = compress($source) ; $dest = uncompress($source) ; $gz = gzopen($filename or filehandle, $mode) ; @@ -483,6 +889,8 @@ Compress::Zlib - Interface to zlib compression library $bytesread = $gz->gzreadline($line) ; $byteswritten = $gz->gzwrite($buffer) ; $status = $gz->gzflush($flush) ; + $offset = $gz->gztell() ; + $status = $gz->gzseek($offset, $whence) ; $status = $gz->gzclose() ; $status = $gz->gzeof() ; $status = $gz->gzsetparams($level, $strategy) ; @@ -495,57 +903,473 @@ Compress::Zlib - Interface to zlib compression library $crc = adler32($buffer [,$crc]) ; $crc = crc32($buffer [,$crc]) ; + $crc = adler32_combine($crc1, $crc2, $len2)l + $crc = crc32_combine($adler1, $adler2, $len2) + ZLIB_VERSION + ZLIB_VERNUM + + # Compress::Zlib 1.x legacy interface + + ($d, $status) = deflateInit( [OPT] ) ; + ($out, $status) = $d->deflate($buffer) ; + $status = $d->deflateParams([OPT]) ; + ($out, $status) = $d->flush() ; + $d->dict_adler() ; + $d->total_in() ; + $d->total_out() ; + $d->msg() ; + + ($i, $status) = inflateInit( [OPT] ) ; + ($out, $status) = $i->inflate($buffer) ; + $status = $i->inflateSync($buffer) ; + $i->dict_adler() ; + $i->total_in() ; + $i->total_out() ; + $i->msg() ; + =head1 DESCRIPTION The I<Compress::Zlib> module provides a Perl interface to the I<zlib> compression library (see L</AUTHOR> for details about where to get -I<zlib>). Most of the functionality provided by I<zlib> is available -in I<Compress::Zlib>. +I<zlib>). +The I<zlib> library allows reading and writing of +compressed data streams that conform to RFC1950, RFC1951 and RFC1952 +(aka gzip). +Most of the I<zlib> functionality is available in I<Compress::Zlib>. + +Unless you are working with legacy code, or you need to work directly +with the low-level zlib interface, it is recommended that applications +use one of the newer C<IO::*> interfaces provided with this module. + +The C<Compress::Zlib> module can be split into two general areas of +functionality, namely a low-level in-memory compression/decompression +interface and a simple read/write interface to I<gzip> files. + +Each of these areas will be discussed separately below. + + +=head1 GZIP INTERFACE + +A number of functions are supplied in I<zlib> for reading and writing +I<gzip> files that conform to RFC1952. This module provides an interface +to most of them. + +If you are upgrading from C<Compress::Zlib> 1.x, the following enhancements +have been made to the C<gzopen> interface: + +=over 5 + +=item 1 + +If you want to to open either STDIN or STDOUT with C<gzopen>, you can +optionally use the special filename "C<->" as a synonym for C<\*STDIN> and +C<\*STDOUT>. + +=item 2 + +In C<Compress::Zlib> version 1.x, C<gzopen> used the zlib library to open the +underlying file. This made things especially tricky when a Perl filehandle was +passed to C<gzopen>. Behind the scenes the numeric C file descriptor had to be +extracted from the Perl filehandle and this passed to the zlib library. + +Apart from being non-portable to some operating systems, this made it difficult +to use C<gzopen> in situations where you wanted to extract/create a gzip data +stream that is embedded in a larger file, without having to resort to opening +and closing the file multiple times. + +In C<Compress::Zlib> version 2.x, the C<gzopen> interface has been completely +rewritten to use the L<IO::Compress::Gzip|IO::Compress::Gzip> for writing gzip files and +L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for reading gzip files. + +=item 3 + +Addition of C<gzseek> to provide a restricted C<seek> interface. + +=item 4. + +Added C<gztell>. + +=back + +A more complete and flexible interface for reading/writing gzip files/buffers +is included with this module. See L<IO::Compress::Gzip|IO::Compress::Gzip> and +L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for more details. + +=over 5 + +=item B<$gz = gzopen($filename, $mode)> + +=item B<$gz = gzopen($filehandle, $mode)> + +This function opens either the I<gzip> file C<$filename> for reading or writing +or attaches to the opened filehandle, C<$filehandle>. It returns an object on +success and C<undef> on failure. + +When writing a gzip file this interface will always create the smallest +possible gzip header (exactly 10 bytes). If you want control over the +information stored in the gzip header (like the original filename or a comment) +use L<IO::Compress::Gzip|IO::Compress::Gzip> instead. + +The second parameter, C<$mode>, is used to specify whether the file is +opened for reading or writing and to optionally specify a compression +level and compression strategy when writing. The format of the C<$mode> +parameter is similar to the mode parameter to the 'C' function C<fopen>, +so "rb" is used to open for reading and "wb" for writing. + +To specify a compression level when writing, append a digit between 0 +and 9 to the mode string -- 0 means no compression and 9 means maximum +compression. +If no compression level is specified Z_DEFAULT_COMPRESSION is used. + +To specify the compression strategy when writing, append 'f' for filtered +data, 'h' for Huffman only compression, or 'R' for run-length encoding. +If no strategy is specified Z_DEFAULT_STRATEGY is used. + +So, for example, "wb9" means open for writing with the maximum compression +using the default strategy and "wb4R" means open for writing with compression +level 4 and run-length encoding. + +Refer to the I<zlib> documentation for the exact format of the C<$mode> +parameter. + + +=item B<$bytesread = $gz-E<gt>gzread($buffer [, $size]) ;> + +Reads C<$size> bytes from the compressed file into C<$buffer>. If +C<$size> is not specified, it will default to 4096. If the scalar +C<$buffer> is not large enough, it will be extended automatically. + +Returns the number of bytes actually read. On EOF it returns 0 and in +the case of an error, -1. + +=item B<$bytesread = $gz-E<gt>gzreadline($line) ;> + +Reads the next line from the compressed file into C<$line>. + +Returns the number of bytes actually read. On EOF it returns 0 and in +the case of an error, -1. + +It is legal to intermix calls to C<gzread> and C<gzreadline>. + +In addition, C<gzreadline> fully supports the use of of the variable C<$/> +(C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Both paragraph mode and file +slurp mode are supported. + + +=item B<$byteswritten = $gz-E<gt>gzwrite($buffer) ;> + +Writes the contents of C<$buffer> to the compressed file. Returns the +number of bytes actually written, or 0 on error. + +=item B<$status = $gz-E<gt>gzflush($flush_type) ;> + +Flushes all pending output into the compressed file. + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + +Returns 1 on success, 0 on failure. + + +=item B<$offset = $gz-E<gt>gztell() ;> + +Returns the uncompressed file offset. + +=item B<$status = $gz-E<gt>gzseek($offset, $whence) ;> + +Sets the file position of the + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the compressed file. +It is a fatal error to attempt to seek backward. + +When opened for writing, empty parts of the file will have NULL (0x00) +bytes written to them. + +The C<$whence> parameter should be one of SEEK_SET, SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=item B<$gz-E<gt>gzclose> + +Closes the compressed file. Any pending data is flushed to the file +before it is closed. + +Returns 1 on success, 0 on failure. + +=item B<$gz-E<gt>gzsetparams($level, $strategy> + +Change settings for the deflate stream C<$gz>. + +The list of the valid options is shown below. Options not specified +will remain unchanged. + +Note: This method is only available if you are running zlib 1.0.6 or better. + +=over 5 + +=item B<$level> + +Defines the compression level. Valid values are 0 through 9, +C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and +C<Z_DEFAULT_COMPRESSION>. + +=item B<$strategy> + +Defines the strategy used to tune the compression. The valid values are +C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>. + +=back + +=item B<$gz-E<gt>gzerror> + +Returns the I<zlib> error message or number for the last operation +associated with C<$gz>. The return value will be the I<zlib> error +number when used in a numeric context and the I<zlib> error message +when used in a string context. The I<zlib> error number constants, +shown below, are available for use. + + Z_OK + Z_STREAM_END + Z_ERRNO + Z_STREAM_ERROR + Z_DATA_ERROR + Z_MEM_ERROR + Z_BUF_ERROR + +=item B<$gzerrno> + +The C<$gzerrno> scalar holds the error code associated with the most +recent I<gzip> routine. Note that unlike C<gzerror()>, the error is +I<not> associated with a particular file. + +As with C<gzerror()> it returns an error number in numeric context and +an error message in string context. Unlike C<gzerror()> though, the +error message will correspond to the I<zlib> message when the error is +associated with I<zlib> itself, or the UNIX error message when it is +not (i.e. I<zlib> returned C<Z_ERRORNO>). + +As there is an overlap between the error numbers used by I<zlib> and +UNIX, C<$gzerrno> should only be used to check for the presence of +I<an> error in numeric context. Use C<gzerror()> to check for specific +I<zlib> errors. The I<gzcat> example below shows how the variable can +be used safely. + +=back + + +=head2 Examples + +Here is an example script which uses the interface. It implements a +I<gzcat> function. + + use strict ; + use warnings ; + + use Compress::Zlib ; + + # use stdin if no files supplied + @ARGV = '-' unless @ARGV ; + + foreach my $file (@ARGV) { + my $buffer ; + + my $gz = gzopen($file, "rb") + or die "Cannot open $file: $gzerrno\n" ; + + print $buffer while $gz->gzread($buffer) > 0 ; + + die "Error reading from $file: $gzerrno" . ($gzerrno+0) . "\n" + if $gzerrno != Z_STREAM_END ; + + $gz->gzclose() ; + } + +Below is a script which makes use of C<gzreadline>. It implements a +very simple I<grep> like script. + + use strict ; + use warnings ; + + use Compress::Zlib ; + + die "Usage: gzgrep pattern [file...]\n" + unless @ARGV >= 1; + + my $pattern = shift ; + + # use stdin if no files supplied + @ARGV = '-' unless @ARGV ; + + foreach my $file (@ARGV) { + my $gz = gzopen($file, "rb") + or die "Cannot open $file: $gzerrno\n" ; + + while ($gz->gzreadline($_) > 0) { + print if /$pattern/ ; + } + + die "Error reading from $file: $gzerrno\n" + if $gzerrno != Z_STREAM_END ; + + $gz->gzclose() ; + } + +This script, I<gzstream>, does the opposite of the I<gzcat> script +above. It reads from standard input and writes a gzip data stream to +standard output. + + use strict ; + use warnings ; + + use Compress::Zlib ; + + binmode STDOUT; # gzopen only sets it on the fd + + my $gz = gzopen(\*STDOUT, "wb") + or die "Cannot open stdout: $gzerrno\n" ; + + while (<>) { + $gz->gzwrite($_) + or die "error writing: $gzerrno\n" ; + } + + $gz->gzclose ; + +=head2 Compress::Zlib::memGzip + +This function is used to create an in-memory gzip file with the minimum +possible gzip header (exactly 10 bytes). + + $dest = Compress::Zlib::memGzip($buffer) ; + +If successful, it returns the in-memory gzip file, otherwise it returns +undef. + +The C<$buffer> parameter can either be a scalar or a scalar reference. + +See L<IO::Compress::Gzip|IO::Compress::Gzip> for an alternative way to carry out in-memory gzip +compression. + +=head2 Compress::Zlib::memGunzip + +This function is used to uncompress an in-memory gzip file. + + $dest = Compress::Zlib::memGunzip($buffer) ; + +If successful, it returns the uncompressed gzip file, otherwise it +returns undef. + +The C<$buffer> parameter can either be a scalar or a scalar reference. The +contents of the C<$buffer> parameter are destroyed after calling this function. + +See L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for an alternative way to carry out in-memory gzip +uncompression. + +=head1 COMPRESS/UNCOMPRESS + +Two functions are provided to perform in-memory compression/uncompression of +RFC 1950 data streams. They are called C<compress> and C<uncompress>. + +=over 5 + +=item B<$dest = compress($source [, $level] ) ;> + +Compresses C<$source>. If successful it returns the compressed +data. Otherwise it returns I<undef>. + +The source buffer, C<$source>, can either be a scalar or a scalar +reference. + +The C<$level> parameter defines the compression level. Valid values are +0 through 9, C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, +C<Z_BEST_COMPRESSION>, and C<Z_DEFAULT_COMPRESSION>. +If C<$level> is not specified C<Z_DEFAULT_COMPRESSION> will be used. + + +=item B<$dest = uncompress($source) ;> + +Uncompresses C<$source>. If successful it returns the uncompressed +data. Otherwise it returns I<undef>. + +The source buffer can either be a scalar or a scalar reference. + +=back + +Please note: the two functions defined above are I<not> compatible with +the Unix commands of the same name. + +See L<IO::Compress::Deflate|IO::Compress::Deflate> and L<IO::Uncompress::Inflate|IO::Uncompress::Inflate> included with +this distribution for an alternative interface for reading/writing RFC 1950 +files/buffers. + +=head1 CHECKSUM FUNCTIONS + +Two functions are provided by I<zlib> to calculate checksums. For the +Perl interface, the order of the two parameters in both functions has +been reversed. This allows both running checksums and one off +calculations to be done. + + $crc = adler32($buffer [,$crc]) ; + $crc = crc32($buffer [,$crc]) ; + +The buffer parameters can either be a scalar or a scalar reference. + +If the $crc parameters is C<undef>, the crc value will be reset. + +If you have built this module with zlib 1.2.3 or better, two more +CRC-related functions are available. + + $crc = adler32_combine($crc1, $crc2, $len2)l + $crc = crc32_combine($adler1, $adler2, $len2) -The module can be split into two general areas of functionality, namely -in-memory compression/decompression and read/write access to I<gzip> -files. Each of these areas will be discussed separately below. +These functions allow checksums to be merged. -=head1 DEFLATE +=head1 Compress::Zlib::Deflate -The interface I<Compress::Zlib> provides to the in-memory I<deflate> -(and I<inflate>) functions has been modified to fit into a Perl model. +This section defines an interface that allows in-memory compression using +the I<deflate> interface provided by zlib. -The main difference is that for both inflation and deflation, the Perl -interface will I<always> consume the complete input buffer before -returning. Also the output buffer returned will be automatically grown -to fit the amount of output available. +Note: The interface defined in this section is different from version +1.x of this module. The original deflate interface is still available +for backward compatibility and is documented in the section +L<Compress::Zlib 1.x Deflate Interface>. Here is a definition of the interface available: -=head2 B<($d, $status) = deflateInit( [OPT] )> +=head2 B<($d, $status) = new Compress::Zlib::Deflate( [OPT] ) > -Initialises a deflation stream. +Initialises a deflation object. -It combines the features of the I<zlib> functions B<deflateInit>, -B<deflateInit2> and B<deflateSetDictionary>. +If you are familiar with the I<zlib> library, it combines the +features of the I<zlib> functions C<deflateInit>, C<deflateInit2> +and C<deflateSetDictionary>. -If successful, it will return the initialised deflation stream, B<$d> -and B<$status> of C<Z_OK> in a list context. In scalar context it -returns the deflation stream, B<$d>, only. +If successful, it will return the initialised deflation object, C<$d> +and a C<$status> of C<Z_OK> in a list context. In scalar context it +returns the deflation object, C<$d>, only. -If not successful, the returned deflation stream (B<$d>) will be -I<undef> and B<$status> will hold the exact I<zlib> error code. +If not successful, the returned deflation object, C<$d>, will be +I<undef> and C<$status> will hold the a I<zlib> error code. The function optionally takes a number of named options specified as -C<-Name=E<gt>value> pairs. This allows individual options to be +C<-Name =E<gt> value> pairs. This allows individual options to be tailored without having to specify them all in the parameter list. For backward compatibility, it is also possible to pass the parameters as a reference to a hash containing the name=>value pairs. -The function takes one optional parameter, a reference to a hash. The -contents of the hash allow the deflation interface to be tailored. - -Here is a list of the valid options: +Below is a list of the valid options: =over 5 @@ -555,87 +1379,124 @@ Defines the compression level. Valid values are 0 through 9, C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and C<Z_DEFAULT_COMPRESSION>. -The default is C<-Level =E<gt>Z_DEFAULT_COMPRESSION>. +The default is C<-Level =E<gt> Z_DEFAULT_COMPRESSION>. =item B<-Method> Defines the compression method. The only valid value at present (and -the default) is C<-Method =E<gt>Z_DEFLATED>. +the default) is C<-Method =E<gt> Z_DEFLATED>. =item B<-WindowBits> -For a definition of the meaning and valid values for B<WindowBits> +For a definition of the meaning and valid values for C<WindowBits> refer to the I<zlib> documentation for I<deflateInit2>. -Defaults to C<-WindowBits =E<gt>MAX_WBITS>. +Defaults to C<-WindowBits =E<gt> MAX_WBITS>. =item B<-MemLevel> -For a definition of the meaning and valid values for B<MemLevel> +For a definition of the meaning and valid values for C<MemLevel> refer to the I<zlib> documentation for I<deflateInit2>. -Defaults to C<-MemLevel =E<gt>MAX_MEM_LEVEL>. +Defaults to C<-MemLevel =E<gt> MAX_MEM_LEVEL>. =item B<-Strategy> Defines the strategy used to tune the compression. The valid values are -C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>. +C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED>, C<Z_RLE>, C<Z_FIXED> and +C<Z_HUFFMAN_ONLY>. The default is C<-Strategy =E<gt>Z_DEFAULT_STRATEGY>. =item B<-Dictionary> When a dictionary is specified I<Compress::Zlib> will automatically -call B<deflateSetDictionary> directly after calling B<deflateInit>. The +call C<deflateSetDictionary> directly after calling C<deflateInit>. The Adler32 value for the dictionary can be obtained by calling the method -C<$d->dict_adler()>. +C<$d-E<gt>dict_adler()>. The default is no dictionary. =item B<-Bufsize> -Sets the initial size for the deflation buffer. If the buffer has to be +Sets the initial size for the output buffer used by the C<$d-E<gt>deflate> +and C<$d-E<gt>flush> methods. If the buffer has to be reallocated to increase the size, it will grow in increments of -B<Bufsize>. +C<Bufsize>. + +The default buffer size is 4096. + +=item B<-AppendOutput> + +This option controls how data is written to the output buffer by the +C<$d-E<gt>deflate> and C<$d-E<gt>flush> methods. + +If the C<AppendOutput> option is set to false, the output buffers in the +C<$d-E<gt>deflate> and C<$d-E<gt>flush> methods will be truncated before +uncompressed data is written to them. + +If the option is set to true, uncompressed data will be appended to the +output buffer in the C<$d-E<gt>deflate> and C<$d-E<gt>flush> methods. + +This option defaults to false. + +=item B<-CRC32> + +If set to true, a crc32 checksum of the uncompressed data will be +calculated. Use the C<$d-E<gt>crc32> method to retrieve this value. + +This option defaults to false. + + +=item B<-ADLER32> + +If set to true, an adler32 checksum of the uncompressed data will be +calculated. Use the C<$d-E<gt>adler32> method to retrieve this value. + +This option defaults to false. -The default is 4096. =back -Here is an example of using the B<deflateInit> optional parameter list -to override the default buffer size and compression level. All other -options will take their default values. +Here is an example of using the C<Compress::Zlib::Deflate> optional +parameter list to override the default buffer size and compression +level. All other options will take their default values. - deflateInit( -Bufsize => 300, - -Level => Z_BEST_SPEED ) ; + my $d = new Compress::Zlib::Deflate ( -Bufsize => 300, + -Level => Z_BEST_SPEED ) ; -=head2 B<($out, $status) = $d-E<gt>deflate($buffer)> +=head2 B<$status = $d-E<gt>deflate($input, $output)> +Deflates the contents of C<$input> and writes the compressed data to +C<$output>. -Deflates the contents of B<$buffer>. The buffer can either be a scalar -or a scalar reference. When finished, B<$buffer> will be -completely processed (assuming there were no errors). If the deflation -was successful it returns the deflated output, B<$out>, and a status -value, B<$status>, of C<Z_OK>. +The C<$input> and C<$output> parameters can be either scalars or scalar +references. -On error, B<$out> will be I<undef> and B<$status> will contain the -I<zlib> error code. +When finished, C<$input> will be completely processed (assuming there +were no errors). If the deflation was successful it writes the deflated +data to C<$output> and returns a status value of C<Z_OK>. -In a scalar context B<deflate> will return B<$out> only. +On error, it returns a I<zlib> error code. -As with the I<deflate> function in I<zlib>, it is not necessarily the -case that any output will be produced by this method. So don't rely on -the fact that B<$out> is empty for an error test. +If the C<AppendOutput> option is set to true in the constructor for +the C<$d> object, the compressed data will be appended to C<$output>. If +it is false, C<$output> will be truncated before any compressed data is +written to it. +B<Note>: This method will not necessarily write compressed data to +C<$output> every time it is called. So do not assume that there has been +an error if the contents of C<$output> is empty on returning from +this method. As long as the return code from the method is C<Z_OK>, +the deflate has succeeded. -=head2 B<($out, $status) = $d-E<gt>flush([flush_type])> +=head2 B<$status = $d-E<gt>flush($output [, $flush_type]) > Typically used to finish the deflation. Any pending output will be -returned via B<$out>. -B<$status> will have a value C<Z_OK> if successful. +written to C<$output>. -In a scalar context B<flush> will return B<$out> only. +Returns C<Z_OK> if successful. Note that flushing can seriously degrade the compression ratio, so it should only be used to terminate a decompression (using C<Z_FINISH>) or @@ -647,13 +1508,19 @@ and C<Z_FULL_FLUSH>. It is strongly recommended that you only set the C<flush_type> parameter if you fully understand the implications of what it does. See the C<zlib> documentation for details. +If the C<AppendOutput> option is set to true in the constructor for +the C<$d> object, the compressed data will be appended to C<$output>. If +it is false, C<$output> will be truncated before any compressed data is +written to it. + =head2 B<$status = $d-E<gt>deflateParams([OPT])> -Change settings for the deflate stream C<$d>. +Change settings for the deflate object C<$d>. The list of the valid options is shown below. Options not specified will remain unchanged. + =over 5 =item B<-Level> @@ -667,12 +1534,39 @@ C<Z_DEFAULT_COMPRESSION>. Defines the strategy used to tune the compression. The valid values are C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>. +=item B<-BufSize> + +Sets the initial size for the output buffer used by the C<$d-E<gt>deflate> +and C<$d-E<gt>flush> methods. If the buffer has to be +reallocated to increase the size, it will grow in increments of +C<Bufsize>. + + =back +=head2 B<$status = $d-E<gt>deflateTune($good_length, $max_lazy, $nice_length, $max_chain)> + +Tune the internal settings for the deflate object C<$d>. This option is +only available if you are running zlib 1.2.2.3 or better. + +Refer to the documentation in zlib.h for instructions on how to fly +C<deflateTune>. + =head2 B<$d-E<gt>dict_adler()> Returns the adler32 value for the dictionary. +=head2 B<$d-E<gt>crc32()> + +Returns the crc32 value for the uncompressed data to date. + +If the C<CRC32> option is not enabled in the constructor for this object, +this method will always return 0; + +=head2 B<$d-E<gt>adler32()> + +Returns the adler32 value for the uncompressed data to date. + =head2 B<$d-E<gt>msg()> Returns the last error message generated by zlib. @@ -685,26 +1579,40 @@ Returns the total number of bytes uncompressed bytes input to deflate. Returns the total number of compressed bytes output from deflate. +=head2 B<$d-E<gt>get_Strategy()> + +Returns the deflation strategy currently used. Valid values are +C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>. + + +=head2 B<$d-E<gt>get_Level()> + +Returns the compression level being used. + +=head2 B<$d-E<gt>get_BufSize()> + +Returns the buffer size used to carry out the compression. + =head2 Example -Here is a trivial example of using B<deflate>. It simply reads standard +Here is a trivial example of using C<deflate>. It simply reads standard input, deflates it and writes it to standard output. use strict ; use warnings ; - use Compress::Zlib ; + use Compress::Zlib 2 ; binmode STDIN; binmode STDOUT; - my $x = deflateInit() + my $x = new Compress::Zlib::Deflate or die "Cannot create a deflation stream\n" ; my ($output, $status) ; while (<>) { - ($output, $status) = $x->deflate($_) ; + $status = $x->deflate($_, $output) ; $status == Z_OK or die "deflation failed\n" ; @@ -712,58 +1620,63 @@ input, deflates it and writes it to standard output. print $output ; } - ($output, $status) = $x->flush() ; + $status = $x->flush($output) ; $status == Z_OK or die "deflation failed\n" ; print $output ; -=head1 INFLATE +=head1 Compress::Zlib::Inflate + +This section defines an interface that allows in-memory uncompression using +the I<inflate> interface provided by zlib. + +Note: The interface defined in this section is different from version +1.x of this module. The original inflate interface is still available +for backward compatibility and is documented in the section +L<Compress::Zlib 1.x Inflate Interface>. Here is a definition of the interface: -=head2 B<($i, $status) = inflateInit()> +=head2 B< ($i, $status) = new Compress::Zlib::Inflate( [OPT] ) > -Initialises an inflation stream. +Initialises an inflation object. -In a list context it returns the inflation stream, B<$i>, and the -I<zlib> status code (B<$status>). In a scalar context it returns the -inflation stream only. +In a list context it returns the inflation object, C<$i>, and the +I<zlib> status code (C<$status>). In a scalar context it returns the +inflation object only. -If successful, B<$i> will hold the inflation stream and B<$status> will +If successful, C<$i> will hold the inflation object and C<$status> will be C<Z_OK>. -If not successful, B<$i> will be I<undef> and B<$status> will hold the +If not successful, C<$i> will be I<undef> and C<$status> will hold the I<zlib> error code. The function optionally takes a number of named options specified as -C<-Name=E<gt>value> pairs. This allows individual options to be +C<-Name =E<gt> value> pairs. This allows individual options to be tailored without having to specify them all in the parameter list. - + For backward compatibility, it is also possible to pass the parameters -as a reference to a hash containing the name=>value pairs. - -The function takes one optional parameter, a reference to a hash. The -contents of the hash allow the deflation interface to be tailored. - +as a reference to a hash containing the name=E<gt>value pairs. + Here is a list of the valid options: =over 5 =item B<-WindowBits> -For a definition of the meaning and valid values for B<WindowBits> +For a definition of the meaning and valid values for C<WindowBits> refer to the I<zlib> documentation for I<inflateInit2>. Defaults to C<-WindowBits =E<gt>MAX_WBITS>. =item B<-Bufsize> -Sets the initial size for the inflation buffer. If the buffer has to be -reallocated to increase the size, it will grow in increments of -B<Bufsize>. +Sets the initial size for the output buffer used by the C<$i-E<gt>inflate> +method. If the output buffer in this method has to be reallocated to +increase the size, it will grow in increments of C<Bufsize>. Default is 4096. @@ -771,51 +1684,119 @@ Default is 4096. The default is no dictionary. +=item B<-AppendOutput> + +This option controls how data is written to the output buffer by the +C<$i-E<gt>inflate> method. + +If the option is set to false, the output buffer in the C<$i-E<gt>inflate> +method will be truncated before uncompressed data is written to it. + +If the option is set to true, uncompressed data will be appended to the +output buffer by the C<$i-E<gt>inflate> method. + +This option defaults to false. + + +=item B<-CRC32> + +If set to true, a crc32 checksum of the uncompressed data will be +calculated. Use the C<$i-E<gt>crc32> method to retrieve this value. + +This option defaults to false. + +=item B<-ADLER32> + +If set to true, an adler32 checksum of the uncompressed data will be +calculated. Use the C<$i-E<gt>adler32> method to retrieve this value. + +This option defaults to false. + +=item B<-ConsumeInput> + +If set to true, this option will remove compressed data from the input +buffer of the the C< $i-E<gt>inflate > method as the inflate progresses. + +This option can be useful when you are processing compressed data that is +embedded in another file/buffer. In this case the data that immediately +follows the compressed stream will be left in the input buffer. + +This option defaults to true. + =back -Here is an example of using the B<inflateInit> optional parameter to -override the default buffer size. +Here is an example of using an optional parameter to override the default +buffer size. - inflateInit( -Bufsize => 300 ) ; + my ($i, $status) = new Compress::Zlib::Inflate( -Bufsize => 300 ) ; -=head2 B<($out, $status) = $i-E<gt>inflate($buffer)> +=head2 B< $status = $i-E<gt>inflate($input, $output) > -Inflates the complete contents of B<$buffer>. The buffer can either be -a scalar or a scalar reference. +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 +scalars or scalar references. Returns C<Z_OK> if successful and C<Z_STREAM_END> if the end of the compressed data has been successfully reached. -If not successful, B<$out> will be I<undef> and B<$status> will hold -the I<zlib> error code. -The C<$buffer> parameter is modified by C<inflate>. On completion it -will contain what remains of the input buffer after inflation. This -means that C<$buffer> will be an empty string when the return status is -C<Z_OK>. When the return status is C<Z_STREAM_END> the C<$buffer> -parameter will contains what (if anything) was stored in the input -buffer after the deflated data stream. +If not successful C<$status> will hold the I<zlib> error code. + +If the C<ConsumeInput> option has been set to true when the +C<Compress::Zlib::Inflate> object is created, the C<$input> parameter +is modified by C<inflate>. On completion it will contain what remains +of the input buffer after inflation. In practice, this means that when +the return status is C<Z_OK> the C<$input> parameter will contain an +empty string, and when the return status is C<Z_STREAM_END> the C<$input> +parameter will contains what (if anything) was stored in the input buffer +after the deflated data stream. This feature is useful when processing a file format that encapsulates -a compressed data stream (e.g. gzip, zip). +a compressed data stream (e.g. gzip, zip) and there is useful data +immediately after the deflation stream. -=head2 B<$status = $i-E<gt>inflateSync($buffer)> +If the C<AppendOutput> option is set to true in the constructor for +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. -Scans C<$buffer> until it reaches either a I<full flush point> or the +=head2 B<$status = $i-E<gt>inflateSync($input)> + +This method can be used to attempt to recover good data from a compressed +data stream that is partially corrupt. +It scans C<$input> until it reaches either a I<full flush point> or the end of the buffer. -If a I<full flush point> is found, C<Z_OK> is returned and C<$buffer> -will be have all data up to the flush point removed. This can then be -passed to the C<deflate> method. +If a I<full flush point> is found, C<Z_OK> is returned and C<$input> +will be have all data up to the flush point removed. This data can then be +passed to the C<$i-E<gt>inflate> method to be uncompressed. Any other return code means that a flush point was not found. If more data is available, C<inflateSync> can be called repeatedly with more compressed data until the flush point is found. +Note I<full flush points> are not present by default in compressed +data streams. They must have been added explicitly when the data stream +was created by calling C<Compress::Deflate::flush> with C<Z_FULL_FLUSH>. + =head2 B<$i-E<gt>dict_adler()> Returns the adler32 value for the dictionary. +=head2 B<$i-E<gt>crc32()> + +Returns the crc32 value for the uncompressed data to date. + +If the C<CRC32> option is not enabled in the constructor for this object, +this method will always return 0; + +=head2 B<$i-E<gt>adler32()> + +Returns the adler32 value for the uncompressed data to date. + +If the C<ADLER32> option is not enabled in the constructor for this object, +this method will always return 0; + =head2 B<$i-E<gt>msg()> Returns the last error message generated by zlib. @@ -828,16 +1809,20 @@ Returns the total number of bytes compressed bytes input to inflate. Returns the total number of uncompressed bytes output from inflate. +=head2 B<$d-E<gt>get_BufSize()> + +Returns the buffer size used to carry out the decompression. + =head2 Example -Here is an example of using B<inflate>. +Here is an example of using C<inflate>. use strict ; use warnings ; - use Compress::Zlib ; + use Compress::Zlib 2 ; - my $x = inflateInit() + my $x = new Compress::Zlib::Inflate() or die "Cannot create a inflation stream\n" ; my $input = '' ; @@ -847,7 +1832,7 @@ Here is an example of using B<inflate>. my ($output, $status) ; while (read(STDIN, $input, 4096)) { - ($output, $status) = $x->inflate(\$input) ; + $status = $x->inflate(\$input, $output) ; print $output if $status == Z_OK or $status == Z_STREAM_END ; @@ -858,415 +1843,411 @@ Here is an example of using B<inflate>. die "inflation failed\n" unless $status == Z_STREAM_END ; -=head1 COMPRESS/UNCOMPRESS +=head1 Compress::Zlib 1.x Deflate Interface + +This section defines the interface available in C<Compress::Zlib> version +1.x that allows in-memory compression using the I<deflate> interface +provided by zlib. + +Here is a definition of the interface available: + + +=head2 B<($d, $status) = deflateInit( [OPT] )> + +Initialises a deflation stream. -Two high-level functions are provided by I<zlib> to perform in-memory -compression/uncompression of RFC1950 data streams. They are called -B<compress> and B<uncompress>. +It combines the features of the I<zlib> functions C<deflateInit>, +C<deflateInit2> and C<deflateSetDictionary>. -The two Perl subs defined below provide the equivalent -functionality. +If successful, it will return the initialised deflation stream, C<$d> +and C<$status> of C<Z_OK> in a list context. In scalar context it +returns the deflation stream, C<$d>, only. + +If not successful, the returned deflation stream (C<$d>) will be +I<undef> and C<$status> will hold the exact I<zlib> error code. + +The function optionally takes a number of named options specified as +C<-Name=E<gt>value> pairs. This allows individual options to be +tailored without having to specify them all in the parameter list. + +For backward compatibility, it is also possible to pass the parameters +as a reference to a hash containing the name=>value pairs. + +The function takes one optional parameter, a reference to a hash. The +contents of the hash allow the deflation interface to be tailored. + +Here is a list of the valid options: =over 5 -=item B<$dest = compress($source [, $level] ) ;> +=item B<-Level> -Compresses B<$source>. If successful it returns the -compressed data. Otherwise it returns I<undef>. +Defines the compression level. Valid values are 0 through 9, +C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and +C<Z_DEFAULT_COMPRESSION>. -The source buffer can either be a scalar or a scalar reference. +The default is C<-Level =E<gt>Z_DEFAULT_COMPRESSION>. -The B<$level> paramter defines the compression level. Valid values are -0 through 9, C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, -C<Z_BEST_COMPRESSION>, and C<Z_DEFAULT_COMPRESSION>. -If B<$level> is not specified C<Z_DEFAULT_COMPRESSION> will be used. +=item B<-Method> +Defines the compression method. The only valid value at present (and +the default) is C<-Method =E<gt>Z_DEFLATED>. -=item B<$dest = uncompress($source) ;> +=item B<-WindowBits> -Uncompresses B<$source>. If successful it returns the uncompressed -data. Otherwise it returns I<undef>. +For a definition of the meaning and valid values for C<WindowBits> +refer to the I<zlib> documentation for I<deflateInit2>. -The source buffer can either be a scalar or a scalar reference. +Defaults to C<-WindowBits =E<gt>MAX_WBITS>. -=back +=item B<-MemLevel> -Please note: the two functions defined above are I<not> compatible with -the Unix commands of the same name. +For a definition of the meaning and valid values for C<MemLevel> +refer to the I<zlib> documentation for I<deflateInit2>. -=head1 GZIP INTERFACE +Defaults to C<-MemLevel =E<gt>MAX_MEM_LEVEL>. -A number of functions are supplied in I<zlib> for reading and writing -I<gzip> files. This module provides an interface to most of them. In -general the interface provided by this module operates identically to -the functions provided by I<zlib>. Any differences are explained -below. +=item B<-Strategy> -=over 5 +Defines the strategy used to tune the compression. The valid values are +C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>. -=item B<$gz = gzopen(filename or filehandle, mode)> +The default is C<-Strategy =E<gt>Z_DEFAULT_STRATEGY>. -This function operates identically to the I<zlib> equivalent except -that it returns an object which is used to access the other I<gzip> -methods. +=item B<-Dictionary> -As with the I<zlib> equivalent, the B<mode> parameter is used to -specify both whether the file is opened for reading or writing and to -optionally specify a a compression level. Refer to the I<zlib> -documentation for the exact format of the B<mode> parameter. +When a dictionary is specified I<Compress::Zlib> will automatically +call C<deflateSetDictionary> directly after calling C<deflateInit>. The +Adler32 value for the dictionary can be obtained by calling the method +C<$d->dict_adler()>. -If a reference to an open filehandle is passed in place of the -filename, gzdopen will be called behind the scenes. The third example -at the end of this section, I<gzstream>, uses this feature. +The default is no dictionary. -=item B<$bytesread = $gz-E<gt>gzread($buffer [, $size]) ;> +=item B<-Bufsize> -Reads B<$size> bytes from the compressed file into B<$buffer>. If -B<$size> is not specified, it will default to 4096. If the scalar -B<$buffer> is not large enough, it will be extended automatically. +Sets the initial size for the deflation buffer. If the buffer has to be +reallocated to increase the size, it will grow in increments of +C<Bufsize>. -Returns the number of bytes actually read. On EOF it returns 0 and in -the case of an error, -1. +The default is 4096. -=item B<$bytesread = $gz-E<gt>gzreadline($line) ;> +=back -Reads the next line from the compressed file into B<$line>. +Here is an example of using the C<deflateInit> optional parameter list +to override the default buffer size and compression level. All other +options will take their default values. -Returns the number of bytes actually read. On EOF it returns 0 and in -the case of an error, -1. + deflateInit( -Bufsize => 300, + -Level => Z_BEST_SPEED ) ; -It is legal to intermix calls to B<gzread> and B<gzreadline>. -At this time B<gzreadline> ignores the variable C<$/> -(C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use). The -end of a line is denoted by the C character C<'\n'>. +=head2 B<($out, $status) = $d-E<gt>deflate($buffer)> -=item B<$byteswritten = $gz-E<gt>gzwrite($buffer) ;> -Writes the contents of B<$buffer> to the compressed file. Returns the -number of bytes actually written, or 0 on error. +Deflates the contents of C<$buffer>. The buffer can either be a scalar +or a scalar reference. When finished, C<$buffer> will be +completely processed (assuming there were no errors). If the deflation +was successful it returns the deflated output, C<$out>, and a status +value, C<$status>, of C<Z_OK>. -=item B<$status = $gz-E<gt>gzflush($flush) ;> +On error, C<$out> will be I<undef> and C<$status> will contain the +I<zlib> error code. -Flushes all pending output to the compressed file. -Works identically to the I<zlib> function it interfaces to. Note that -the use of B<gzflush> can degrade compression. +In a scalar context C<deflate> will return C<$out> only. -Returns C<Z_OK> if B<$flush> is C<Z_FINISH> and all output could be -flushed. Otherwise the zlib error code is returned. +As with the I<deflate> function in I<zlib>, it is not necessarily the +case that any output will be produced by this method. So don't rely on +the fact that C<$out> is empty for an error test. -Refer to the I<zlib> documentation for the valid values of B<$flush>. -=item B<$status = $gz-E<gt>gzeof() ;> +=head2 B<($out, $status) = $d-E<gt>flush([flush_type])> -Returns 1 if the end of file has been detected while reading the input -file, otherwise returns 0. +Typically used to finish the deflation. Any pending output will be +returned via C<$out>. +C<$status> will have a value C<Z_OK> if successful. -=item B<$gz-E<gt>gzclose> +In a scalar context C<flush> will return C<$out> only. -Closes the compressed file. Any pending data is flushed to the file -before it is closed. +Note that flushing can seriously degrade the compression ratio, so it +should only be used to terminate a decompression (using C<Z_FINISH>) or +when you want to create a I<full flush point> (using C<Z_FULL_FLUSH>). -=item B<$gz-E<gt>gzsetparams($level, $strategy> +By default the C<flush_type> used is C<Z_FINISH>. Other valid values +for C<flush_type> are C<Z_NO_FLUSH>, C<Z_PARTIAL_FLUSH>, C<Z_SYNC_FLUSH> +and C<Z_FULL_FLUSH>. It is strongly recommended that you only set the +C<flush_type> parameter if you fully understand the implications of +what it does. See the C<zlib> documentation for details. -Change settings for the deflate stream C<$gz>. +=head2 B<$status = $d-E<gt>deflateParams([OPT])> + +Change settings for the deflate stream C<$d>. The list of the valid options is shown below. Options not specified will remain unchanged. -Note: This method is only available if you are running zlib 1.0.6 or better. - =over 5 -=item B<$level> +=item B<-Level> Defines the compression level. Valid values are 0 through 9, C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and C<Z_DEFAULT_COMPRESSION>. -=item B<$strategy> +=item B<-Strategy> Defines the strategy used to tune the compression. The valid values are C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>. =back -=item B<$gz-E<gt>gzerror> +=head2 B<$d-E<gt>dict_adler()> -Returns the I<zlib> error message or number for the last operation -associated with B<$gz>. The return value will be the I<zlib> error -number when used in a numeric context and the I<zlib> error message -when used in a string context. The I<zlib> error number constants, -shown below, are available for use. +Returns the adler32 value for the dictionary. - Z_OK - Z_STREAM_END - Z_ERRNO - Z_STREAM_ERROR - Z_DATA_ERROR - Z_MEM_ERROR - Z_BUF_ERROR +=head2 B<$d-E<gt>msg()> -=item B<$gzerrno> +Returns the last error message generated by zlib. -The B<$gzerrno> scalar holds the error code associated with the most -recent I<gzip> routine. Note that unlike B<gzerror()>, the error is -I<not> associated with a particular file. +=head2 B<$d-E<gt>total_in()> -As with B<gzerror()> it returns an error number in numeric context and -an error message in string context. Unlike B<gzerror()> though, the -error message will correspond to the I<zlib> message when the error is -associated with I<zlib> itself, or the UNIX error message when it is -not (i.e. I<zlib> returned C<Z_ERRORNO>). +Returns the total number of bytes uncompressed bytes input to deflate. -As there is an overlap between the error numbers used by I<zlib> and -UNIX, B<$gzerrno> should only be used to check for the presence of -I<an> error in numeric context. Use B<gzerror()> to check for specific -I<zlib> errors. The I<gzcat> example below shows how the variable can -be used safely. +=head2 B<$d-E<gt>total_out()> -=back +Returns the total number of compressed bytes output from deflate. +=head2 Example -=head2 Examples -Here is an example script which uses the interface. It implements a -I<gzcat> function. +Here is a trivial example of using C<deflate>. It simply reads standard +input, deflates it and writes it to standard output. use strict ; use warnings ; - + use Compress::Zlib ; - - die "Usage: gzcat file...\n" - unless @ARGV ; - - my $file ; - - foreach $file (@ARGV) { - my $buffer ; - - my $gz = gzopen($file, "rb") - or die "Cannot open $file: $gzerrno\n" ; - - print $buffer while $gz->gzread($buffer) > 0 ; - - die "Error reading from $file: $gzerrno" . ($gzerrno+0) . "\n" - if $gzerrno != Z_STREAM_END ; - - $gz->gzclose() ; - } -Below is a script which makes use of B<gzreadline>. It implements a -very simple I<grep> like script. + binmode STDIN; + binmode STDOUT; + my $x = deflateInit() + or die "Cannot create a deflation stream\n" ; - use strict ; - use warnings ; - - use Compress::Zlib ; - - die "Usage: gzgrep pattern file...\n" - unless @ARGV >= 2; - - my $pattern = shift ; - - my $file ; - - foreach $file (@ARGV) { - my $gz = gzopen($file, "rb") - or die "Cannot open $file: $gzerrno\n" ; + my ($output, $status) ; + while (<>) + { + ($output, $status) = $x->deflate($_) ; - while ($gz->gzreadline($_) > 0) { - print if /$pattern/ ; - } + $status == Z_OK + or die "deflation failed\n" ; - die "Error reading from $file: $gzerrno\n" - if $gzerrno != Z_STREAM_END ; - - $gz->gzclose() ; + print $output ; } - -This script, I<gzstream>, does the opposite of the I<gzcat> script -above. It reads from standard input and writes a gzip file to standard -output. - - use strict ; - use warnings ; - use Compress::Zlib ; - - binmode STDOUT; # gzopen only sets it on the fd + ($output, $status) = $x->flush() ; - my $gz = gzopen(\*STDOUT, "wb") - or die "Cannot open stdout: $gzerrno\n" ; + $status == Z_OK + or die "deflation failed\n" ; - while (<>) { - $gz->gzwrite($_) - or die "error writing: $gzerrno\n" ; - } + print $output ; - $gz->gzclose ; +=head1 Compress::Zlib 1.x Inflate Interface -=head2 Compress::Zlib::memGzip +This section defines the interface available in C<Compress::Zlib> version +1.x that allows in-memory uncompression using the I<deflate> interface +provided by zlib. -This function is used to create an in-memory gzip file. -It creates a minimal gzip header. +Here is a definition of the interface: - $dest = Compress::Zlib::memGzip($buffer) ; -If successful, it returns the in-memory gzip file, otherwise it returns -undef. +=head2 B<($i, $status) = inflateInit()> -The buffer parameter can either be a scalar or a scalar reference. +Initialises an inflation stream. -=head2 Compress::Zlib::memGunzip +In a list context it returns the inflation stream, C<$i>, and the +I<zlib> status code (C<$status>). In a scalar context it returns the +inflation stream only. -This function is used to uncompress an in-memory gzip file. +If successful, C<$i> will hold the inflation stream and C<$status> will +be C<Z_OK>. - $dest = Compress::Zlib::memGunzip($buffer) ; +If not successful, C<$i> will be I<undef> and C<$status> will hold the +I<zlib> error code. -If successful, it returns the uncompressed gzip file, otherwise it -returns undef. +The function optionally takes a number of named options specified as +C<-Name=E<gt>value> pairs. This allows individual options to be +tailored without having to specify them all in the parameter list. + +For backward compatibility, it is also possible to pass the parameters +as a reference to a hash containing the name=>value pairs. + +The function takes one optional parameter, a reference to a hash. The +contents of the hash allow the deflation interface to be tailored. + +Here is a list of the valid options: -The buffer parameter can either be a scalar or a scalar reference. The -contents of the buffer parameter are destroyed after calling this -function. +=over 5 -=head1 CHECKSUM FUNCTIONS +=item B<-WindowBits> -Two functions are provided by I<zlib> to calculate a checksum. For the -Perl interface, the order of the two parameters in both functions has -been reversed. This allows both running checksums and one off -calculations to be done. +For a definition of the meaning and valid values for C<WindowBits> +refer to the I<zlib> documentation for I<inflateInit2>. - $crc = adler32($buffer [,$crc]) ; - $crc = crc32($buffer [,$crc]) ; +Defaults to C<-WindowBits =E<gt>MAX_WBITS>. -The buffer parameters can either be a scalar or a scalar reference. +=item B<-Bufsize> -If the $crc parameters is C<undef>, the crc value will be reset. +Sets the initial size for the inflation buffer. If the buffer has to be +reallocated to increase the size, it will grow in increments of +C<Bufsize>. -=head1 FAQ +Default is 4096. -=head2 Compatibility with Unix compress/uncompress. +=item B<-Dictionary> -Although C<Compress::Zlib> has a pair of functions called C<compress> -and C<uncompress>, they are I<not> the same as the Unix programs of the -same name. The C<Compress::Zlib> library is not compatable with Unix -C<compress>. +The default is no dictionary. -If you have the C<uncompress> program available, you can use this to -read compressed files +=back - open F, "uncompress -c $filename |"; - while (<F>) - { - ... +Here is an example of using the C<inflateInit> optional parameter to +override the default buffer size. -If you have the C<gunzip> program available, you can use this to read -compressed files + inflateInit( -Bufsize => 300 ) ; - open F, "gunzip -c $filename |"; - while (<F>) - { - ... +=head2 B<($out, $status) = $i-E<gt>inflate($buffer)> -and this to write compress files if you have the C<compress> program -available +Inflates the complete contents of C<$buffer>. The buffer can either be +a scalar or a scalar reference. - open F, "| compress -c $filename "; - print F "data"; - ... - close F ; +Returns C<Z_OK> if successful and C<Z_STREAM_END> if the end of the +compressed data has been successfully reached. +If not successful, C<$out> will be I<undef> and C<$status> will hold +the I<zlib> error code. -=head2 Accessing .tar.Z files +The C<$buffer> parameter is modified by C<inflate>. On completion it +will contain what remains of the input buffer after inflation. This +means that C<$buffer> will be an empty string when the return status is +C<Z_OK>. When the return status is C<Z_STREAM_END> the C<$buffer> +parameter will contains what (if anything) was stored in the input +buffer after the deflated data stream. -The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via -the C<IO::Zlib> module) to access tar files that have been compressed -with C<gzip>. Unfortunately tar files compressed with the Unix C<compress> -utility cannot be read by C<Compress::Zlib> and so cannot be directly -accesses by C<Archive::Tar>. +This feature is useful when processing a file format that encapsulates +a compressed data stream (e.g. gzip, zip). -If the C<uncompress> or C<gunzip> programs are available, you can use -one of these workarounds to read C<.tar.Z> files from C<Archive::Tar> +=head2 B<$status = $i-E<gt>inflateSync($buffer)> -Firstly with C<uncompress> +Scans C<$buffer> until it reaches either a I<full flush point> or the +end of the buffer. - use strict; - use warnings; - use Archive::Tar; +If a I<full flush point> is found, C<Z_OK> is returned and C<$buffer> +will be have all data up to the flush point removed. This can then be +passed to the C<deflate> method. - open F, "uncompress -c $filename |"; - my $tar = Archive::Tar->new(*F); - ... +Any other return code means that a flush point was not found. If more +data is available, C<inflateSync> can be called repeatedly with more +compressed data until the flush point is found. -and this with C<gunzip> - use strict; - use warnings; - use Archive::Tar; +=head2 B<$i-E<gt>dict_adler()> - open F, "gunzip -c $filename |"; - my $tar = Archive::Tar->new(*F); - ... +Returns the adler32 value for the dictionary. -Similarly, if the C<compress> program is available, you can use this to -write a C<.tar.Z> file +=head2 B<$i-E<gt>msg()> - use strict; - use warnings; - use Archive::Tar; - use IO::File; +Returns the last error message generated by zlib. - my $fh = newIO::File "| compress -c >$filename"; - my $tar = Archive::Tar->new(); - ... - $tar->write($fh); - $fh->close ; +=head2 B<$i-E<gt>total_in()> -=head2 Accessing ZIP Files +Returns the total number of bytes compressed bytes input to inflate. -Although it is possible to use this module to access .zip files, there -is a module on CPAN that will do all the hard work for you. Check out +=head2 B<$i-E<gt>total_out()> - http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz +Returns the total number of uncompressed bytes output from inflate. -Assuming you don't want to use this module to access zip files there -are a number of undocumented features in the zlib library you need to -be aware of. +=head2 Example -=over 5 +Here is an example of using C<inflate>. -=item 1. + use strict ; + use warnings ; + + use Compress::Zlib ; + + my $x = inflateInit() + or die "Cannot create a inflation stream\n" ; + + my $input = '' ; + binmode STDIN; + binmode STDOUT; + + my ($output, $status) ; + while (read(STDIN, $input, 4096)) + { + ($output, $status) = $x->inflate(\$input) ; + + print $output + if $status == Z_OK or $status == Z_STREAM_END ; + + last if $status != Z_OK ; + } + + die "inflation failed\n" + unless $status == Z_STREAM_END ; -When calling B<inflateInit> or B<deflateInit> the B<WindowBits> parameter -must be set to C<-MAX_WBITS>. This disables the creation of the zlib -header. +=head1 ACCESSING ZIP FILES -=item 2. +Although it is possible (with some effort on your part) to use this +module to access .zip files, there is a module on CPAN that will do all +the hard work for you. Check out the C<Archive::Zip> module on CPAN at -The zlib function B<inflate>, and so the B<inflate> method supplied in -this module, assume that there is at least one trailing byte after the -compressed data stream. Normally this isn't a problem because both -the gzip and zip file formats will guarantee that there is data directly -after the compressed data stream. + http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz -=back =head1 CONSTANTS All the I<zlib> constants are automatically imported when you make use of I<Compress::Zlib>. + +=head1 SEE ALSO + +L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::AnyInflate> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for the gzip program is F<http://www.gzip.org>. + =head1 AUTHOR The I<Compress::Zlib> module was written by Paul Marquess, F<pmqs@cpan.org>. The latest copy of the module can be found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>. +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + The primary site for the I<zlib> compression library is F<http://www.zlib.org>. =head1 MODIFICATION HISTORY See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 1995-2005 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 6f02146313..3fce623cd4 100644 --- a/ext/Compress/Zlib/Zlib.xs +++ b/ext/Compress/Zlib/Zlib.xs @@ -1,7 +1,7 @@ /* Filename: Zlib.xs * Author : Paul Marquess, <pmqs@cpan.org> - * Created : 30 January 2005 - * Version : 1.40 + * Created : 22nd January 1996 + * Version : 2.000 * * Copyright (c) 1995-2005 Paul Marquess. All rights reserved. * This program is free software; you can redistribute it and/or @@ -9,13 +9,22 @@ * */ -/* Part of this code is based on the file gzio.c */ +/* Parts of this code are based on the files gzio.c and gzappend.c from + * the standard zlib source distribution. Below are the copyright statements + * from each. + */ /* gzio.c -- IO on .gz files * Copyright (C) 1995 Jean-loup Gailly. * For conditions of distribution and use, see copyright notice in zlib.h */ +/* gzappend -- command to append to a gzip file + + Copyright (C) 2003 Mark Adler, all rights reserved + version 1.1, 4 Nov 2003 +*/ + #include "EXTERN.h" @@ -24,67 +33,243 @@ #include <zlib.h> -#ifndef PERL_VERSION -#include "patchlevel.h" -#define PERL_REVISION 5 -#define PERL_VERSION PATCHLEVEL -#define PERL_SUBVERSION SUBVERSION + +#if defined(ZLIB_VERNUM) && ZLIB_VERNUM >= 0x1210 +# define MAGIC_APPEND +#endif + +#if defined(ZLIB_VERNUM) && ZLIB_VERNUM >= 0x1221 +# define AT_LEAST_ZLIB_1_2_2_1 +#endif + +#if defined(ZLIB_VERNUM) && ZLIB_VERNUM >= 0x1223 +# define AT_LEAST_ZLIB_1_2_2_3 +#endif + +#if defined(ZLIB_VERNUM) && ZLIB_VERNUM >= 0x1230 +# define AT_LEAST_ZLIB_1_2_3 +#endif + +#if 0 + +# include "ppport.h" + +#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 +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION +# endif + +# if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) + +# define PL_sv_undef sv_undef +# define PL_na na +# define PL_curcop curcop +# define PL_compiling compiling + +# endif + +# ifndef newSVuv +# 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 )) + +# ifdef SvPVbyte_force +# undef SvPVbyte_force +# endif + +# define SvPVbyte_force(sv,lp) SvPV_force(sv,lp) + +#endif + +#ifndef SvPVbyte_nolen +# define SvPVbyte_nolen SvPV_nolen +#endif + +#ifndef SvPVbyte +# define SvPVbyte SvPV +#endif + +#ifndef dTHX +# define dTHX #endif -#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) +#ifndef SvPV_nolen + +#define sv_2pv_nolen(a) my_sv_2pv_nolen(a) + +static char * +my_sv_2pv_nolen(register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + + +/* SvPV_nolen depends on sv_2pv_nolen */ +#define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) -# define PL_sv_undef sv_undef -# define PL_na na -# define PL_curcop curcop -# define PL_compiling compiling #endif -#ifndef newSVuv -# define newSVuv newSViv +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif +typedef int DualType ; +typedef int int_undef ; + typedef struct di_stream { + int flags ; +#define FLAG_APPEND 1 +#define FLAG_CRC32 2 +#define FLAG_ADLER32 4 +#define FLAG_CONSUME_INPUT 8 + uLong crc32 ; + uLong adler32 ; z_stream stream; - uLong bufsize; - uLong bufinc; + uLong bufsize; + uLong bufinc; SV * dictionary ; uLong dict_adler ; + int last_error ; + bool zip_mode ; +#define SETP_BYTE +#ifdef SETP_BYTE bool deflateParams_out_valid ; Bytef deflateParams_out_byte; +#else +#define deflateParams_BUFFER_SIZE 0x4000 + uLong deflateParams_out_length; + Bytef* deflateParams_out_buffer; +#endif int Level; int Method; int WindowBits; int MemLevel; int Strategy; + uLong bytesInflated ; +#ifdef MAGIC_APPEND + +#define WINDOW_SIZE 32768U + + bool matchedEndBlock; + Bytef* window ; + int window_lastbit, window_left, window_full; + unsigned window_have; + off_t window_lastoff, window_end; + off_t window_endOffset; + + uLong lastBlockOffset ; + unsigned char window_lastByte ; + + +#endif } di_stream; typedef di_stream * deflateStream ; typedef di_stream * Compress__Zlib__deflateStream ; typedef di_stream * inflateStream ; typedef di_stream * Compress__Zlib__inflateStream ; +typedef di_stream * Compress__Zlib__inflateScanStream ; -/* typedef gzFile Compress__Zlib__gzFile ; */ -typedef struct gzType { - gzFile gz ; - SV * buffer ; - uLong offset ; - bool closed ; -} gzType ; +#define GZERRNO "Compress::Zlib::gzerrno" -typedef gzType* Compress__Zlib__gzFile ; +#define ZMALLOC(to, typ) ((to = (typ *)safemalloc(sizeof(typ))), \ + Zero(to,1,typ)) +/* Figure out the Operating System */ +#ifdef MSDOS +# define OS_CODE 0x00 +#endif +#if defined(AMIGA) || defined(AMIGAOS) +# define OS_CODE 0x01 +#endif + +#if defined(VAXC) || defined(VMS) +# define OS_CODE 0x02 +#endif -#define GZERRNO "Compress::Zlib::gzerrno" +#if 0 /* VM/CMS */ +# define OS_CODE 0x04 +#endif + +#if defined(ATARI) || defined(atarist) +# define OS_CODE 0x05 +#endif + +#ifdef OS2 +# define OS_CODE 0x06 +#endif + +#if defined(MACOS) || defined(TARGET_OS_MAC) +# define OS_CODE 0x07 +#endif -#define ZMALLOC(to, typ) ((to = (typ *)safemalloc(sizeof(typ))), \ - Zero(to,1,typ)) +#if 0 /* Z-System */ +# define OS_CODE 0x08 +#endif + +#if 0 /* CP/M */ +# define OS_CODE 0x09 +#endif + +#ifdef TOPS20 +# define OS_CODE 0x0a +#endif + +#ifdef WIN32 /* Window 95 & Windows NT */ +# define OS_CODE 0x0b +#endif + +#if 0 /* QDOS */ +# define OS_CODE 0x0c +#endif + +#if 0 /* Acorn RISCOS */ +# define OS_CODE 0x0d +#endif + +#if 0 /* ??? */ +# define OS_CODE 0x0e +#endif + +#ifdef __50SERIES /* Prime/PRIMOS */ +# define OS_CODE 0x0F +#endif + +/* Default to UNIX */ +#ifndef OS_CODE +# define OS_CODE 0x03 /* assume Unix */ +#endif + +#ifndef GZIP_OS_CODE +# define GZIP_OS_CODE OS_CODE +#endif #define adlerInitial adler32(0L, Z_NULL, 0) #define crcInitial crc32(0L, Z_NULL, 0) -#if 1 + static const char * const my_z_errmsg[] = { "need dictionary", /* Z_NEED_DICT 2 */ "stream end", /* Z_STREAM_END 1 */ @@ -96,8 +281,13 @@ static const char * const my_z_errmsg[] = { "buffer error", /* Z_BUF_ERROR (-5) */ "incompatible version",/* Z_VERSION_ERROR(-6) */ ""}; -#endif +#define setDUALstatus(var, err) \ + sv_setnv(var, (double)err) ; \ + sv_setpv(var, ((err) ? GetErrorString(err) : "")) ; \ + SvNOK_on(var); + + #if defined(__SYMBIAN32__) # define NO_WRITEABLE_DATA #endif @@ -105,14 +295,36 @@ static const char * const my_z_errmsg[] = { #define TRACE_DEFAULT 0 #ifdef NO_WRITEABLE_DATA -#define trace TRACE_DEFAULT +# define trace TRACE_DEFAULT #else -static int trace = TRACE_DEFAULT ; + static int trace = TRACE_DEFAULT ; #endif /* Dodge PerlIO hiding of these functions. */ #undef printf +static char * +#ifdef CAN_PROTOTYPE +GetErrorString(int error_no) +#else +GetErrorString(error_no) +int error_no ; +#endif +{ + dTHX; + char * errstr ; + + if (error_no == Z_ERRNO) { + errstr = Strerror(errno) ; + } + else + /* errstr = gzerror(fil, &error_no) ; */ + errstr = (char*) my_z_errmsg[2 - error_no]; + + return errstr ; +} + +#if 0 static void #ifdef CAN_PROTOTYPE SetGzErrorNo(int error_no) @@ -121,9 +333,6 @@ SetGzErrorNo(error_no) int error_no ; #endif { -#ifdef dTHX - dTHX; -#endif char * errstr ; SV * gzerror_sv = perl_get_sv(GZERRNO, FALSE) ; @@ -143,6 +352,7 @@ int error_no ; } + static void #ifdef CAN_PROTOTYPE SetGzError(gzFile file) @@ -157,6 +367,104 @@ gzFile file ; SetGzErrorNo(error_no) ; } +#endif + +#ifdef MAGIC_APPEND + +/* + The following two functions are taken almost directly from + examples/gzappend.c. Only cosmetic changes have been made to conform to + the coding style of the rest of the code in this file. +*/ + + +/* return the greatest common divisor of a and b using Euclid's algorithm, + modified to be fast when one argument much greater than the other, and + coded to avoid unnecessary swapping */ +static unsigned +#ifdef CAN_PROTOTYPE +gcd(unsigned a, unsigned b) +#else +gcd(a, b) + unsigned a; + unsigned b; +#endif +{ + unsigned c; + + while (a && b) + if (a > b) { + c = b; + while (a - c >= c) + c <<= 1; + a -= c; + } + else { + c = a; + while (b - c >= c) + c <<= 1; + b -= c; + } + return a + b; +} + +/* rotate list[0..len-1] left by rot positions, in place */ +static void +#ifdef CAN_PROTOTYPE +rotate(unsigned char *list, unsigned len, unsigned rot) +#else +rotate(list, len, rot) + unsigned char *list; + unsigned len ; + unsigned rot; +#endif +{ + unsigned char tmp; + unsigned cycles; + unsigned char *start, *last, *to, *from; + + /* normalize rot and handle degenerate cases */ + if (len < 2) return; + if (rot >= len) rot %= len; + if (rot == 0) return; + + /* pointer to last entry in list */ + last = list + (len - 1); + + /* do simple left shift by one */ + if (rot == 1) { + tmp = *list; + memcpy(list, list + 1, len - 1); + *last = tmp; + return; + } + + /* do simple right shift by one */ + if (rot == len - 1) { + tmp = *last; + memmove(list + 1, list, len - 1); + *list = tmp; + return; + } + + /* otherwise do rotate as a set of cycles in place */ + cycles = gcd(len, rot); /* number of cycles */ + do { + start = from = list + cycles; /* start index is arbitrary */ + tmp = *from; /* save entry to be overwritten */ + for (;;) { + to = from; /* next step in cycle */ + from += rot; /* go right rot positions */ + if (from > last) from -= len; /* (pointer better not wrap) */ + if (from == start) break; /* all but one shifted */ + *to = *from; /* shift left */ + } + *to = tmp; /* complete the circle */ + } while (--cycles); +} + +#endif /* MAGIC_APPEND */ + static void #ifdef CAN_PROTOTYPE DispHex(void * ptr, int length) @@ -189,128 +497,102 @@ DispStream(s, message) return ; #endif - printf("DispStream 0x%p - %s \n", s, message) ; +#define EnDis(f) (s->flags & f ? "Enabled" : "Disabled") + + printf("DispStream 0x%p", s) ; + if (message) + printf("- %s \n", message) ; + printf("\n") ; if (!s) { - printf(" stream pointer is NULL\n"); + printf(" stream pointer is NULL\n"); } else { - printf(" stream 0x%p\n", &(s->stream)); - printf(" zalloc 0x%p\n", s->stream.zalloc); - printf(" zfree 0x%p\n", s->stream.zfree); - printf(" opaque 0x%p\n", s->stream.opaque); - if (s->stream.msg) - printf(" msg %s\n", s->stream.msg); - else - printf(" msg \n"); - printf(" next_in 0x%p", s->stream.next_in); - if (s->stream.next_in) { - printf(" =>"); + printf(" stream 0x%p\n", &(s->stream)); + printf(" zalloc 0x%p\n", s->stream.zalloc); + printf(" zfree 0x%p\n", s->stream.zfree); + printf(" opaque 0x%p\n", s->stream.opaque); + if (s->stream.msg) + printf(" msg %s\n", s->stream.msg); + else + printf(" msg \n"); + printf(" next_in 0x%p", s->stream.next_in); + if (s->stream.next_in){ + printf(" =>"); DispHex(s->stream.next_in, 4); - } + } printf("\n"); - printf(" next_out 0x%p", s->stream.next_out); - if (s->stream.next_out){ - printf(" =>"); + printf(" next_out 0x%p", s->stream.next_out); + if (s->stream.next_out){ + printf(" =>"); DispHex(s->stream.next_out, 4); - } + } printf("\n"); - printf(" avail_in %ld\n", s->stream.avail_in); - printf(" avail_out %ld\n", s->stream.avail_out); - printf(" total_in %ld\n", s->stream.total_in); - printf(" total_out %ld\n", s->stream.total_out); - printf(" adler 0x%lx\n", s->stream.adler); - printf(" reserved 0x%lx\n", s->stream.reserved); - printf(" bufsize %ld\n", s->bufsize); - printf(" dictionary 0x%p\n", s->dictionary); - printf(" dict_adler 0x%ld\n", s->dict_adler); - printf("\n"); + printf(" avail_in %lu\n", (unsigned long)s->stream.avail_in); + printf(" avail_out %lu\n", (unsigned long)s->stream.avail_out); + printf(" total_in %ld\n", s->stream.total_in); + printf(" total_out %ld\n", s->stream.total_out); + printf(" adler %ld\n", s->stream.adler ); + printf(" bufsize %ld\n", s->bufsize); + printf(" dictionary 0x%p\n", s->dictionary); + printf(" dict_adler 0x%ld\n",s->dict_adler); + printf(" zip_mode %d\n", s->zip_mode); + printf(" crc32 0x%x\n", (unsigned)s->crc32); + printf(" adler32 0x%x\n", (unsigned)s->adler32); + printf(" flags 0x%x\n", s->flags); + printf(" APPEND %s\n", EnDis(FLAG_APPEND)); + printf(" CRC32 %s\n", EnDis(FLAG_CRC32)); + printf(" ADLER32 %s\n", EnDis(FLAG_ADLER32)); + printf(" CONSUME %s\n", EnDis(FLAG_CONSUME_INPUT)); + +#ifdef MAGIC_APPEND + printf(" window 0x%p\n", s->window); +#endif + printf("\n"); } } - static di_stream * #ifdef CAN_PROTOTYPE -InitStream(uLong bufsize) +InitStream(void) #else -InitStream(bufsize) - uLong bufsize ; +InitStream() #endif { di_stream *s ; ZMALLOC(s, di_stream) ; - if (s) { - s->bufsize = bufsize ; - s->bufinc = bufsize ; - } - return s ; } -#define SIZE 4096 - -static int +static void #ifdef CAN_PROTOTYPE -gzreadline(Compress__Zlib__gzFile file, SV * output) +PostInitStream(di_stream * s, int flags, int bufsize, int windowBits) #else -gzreadline(file, output) - Compress__Zlib__gzFile file ; - SV * output ; +PostInitStream(s, flags, bufsize, windowBits) + di_stream *s ; + int flags ; + int bufsize ; + int windowBits ; #endif { -#ifdef dTHX - dTHX; -#endif - SV * store = file->buffer ; - char *nl = "\n"; - char *p; - char *out_ptr = SvPVX(store) ; - int n; - - while (1) { - - /* anything left from last time */ - if ((n = SvCUR(store))) { - - out_ptr = SvPVX(store) + file->offset ; - if ((p = ninstr(out_ptr, out_ptr + n - 1, nl, nl))) { - /* if (rschar != 0777 && */ - /* p = ninstr(out_ptr, out_ptr + n - 1, rs, rs+rslen-1)) { */ - - sv_catpvn(output, out_ptr, p - out_ptr + 1); - - file->offset += (p - out_ptr + 1) ; - n = n - (p - out_ptr + 1); - SvCUR_set(store, n) ; - return SvCUR(output); - } - else /* no EOL, so append the complete buffer */ - sv_catpvn(output, out_ptr, n); - - } - - - SvCUR_set(store, 0) ; - file->offset = 0 ; - out_ptr = SvPVX(store) ; - - n = gzread(file->gz, out_ptr, SIZE) ; - - if (n <= 0) - /* Either EOF or an error */ - /* so return what we have so far else signal eof */ - return (SvCUR(output)>0) ? SvCUR(output) : n ; - - SvCUR_set(store, n) ; - } + s->bufsize = bufsize ; + s->bufinc = bufsize ; + s->last_error = 0 ; + s->flags = flags ; + s->zip_mode = (windowBits < 0) ; + if (flags & FLAG_CRC32) + s->crc32 = crcInitial ; + if (flags & FLAG_ADLER32) + s->adler32 = adlerInitial ; } + static SV* #ifdef CAN_PROTOTYPE deRef(SV * sv, char * string) @@ -320,30 +602,76 @@ SV * sv ; char * string; #endif { -#ifdef dTHX dTHX; -#endif + SvGETMAGIC(sv); + if (SvROK(sv)) { - sv = SvRV(sv) ; - switch(SvTYPE(sv)) { + sv = SvRV(sv) ; + SvGETMAGIC(sv); + switch(SvTYPE(sv)) { case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: croak("%s: buffer parameter is not a SCALAR reference", string); - } - if (SvROK(sv)) - croak("%s: buffer parameter is a reference to a reference", string) ; + } + if (SvROK(sv)) + croak("%s: buffer parameter is a reference to a reference", string) ; } if (!SvOK(sv)) { sv = newSVpv("", 0); - } + } + + return sv ; +} + +static SV* +#ifdef CAN_PROTOTYPE +deRef_l(SV * sv, char * string) +#else +deRef_l(sv, string) +SV * sv ; +char * string ; +#endif +{ + bool wipe = 0 ; + + SvGETMAGIC(sv); + wipe = ! SvOK(sv) ; + + if (SvROK(sv)) { + sv = SvRV(sv) ; + SvGETMAGIC(sv); + wipe = ! SvOK(sv) ; + + switch(SvTYPE(sv)) { + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + croak("%s: buffer parameter is not a SCALAR reference", string); + } + if (SvROK(sv)) + croak("%s: buffer parameter is a reference to a reference", string) ; + } + + if (SvREADONLY(sv) && PL_curcop != &PL_compiling) + croak("%s: buffer parameter is read-only", string); + + SvUPGRADE(sv, SVt_PV); + + if (wipe) + SvCUR_set(sv, 0); + + SvOOK_off(sv); + SvPOK_only(sv); + return sv ; } + #include "constants.h" -MODULE = Compress::Zlib PACKAGE = Compress::Zlib PREFIX = Zip_ +MODULE = Compress::Zlib PACKAGE = Compress::Zlib PREFIX = Zip_ REQUIRE: 1.924 PROTOTYPES: DISABLE @@ -356,6 +684,12 @@ BOOT: croak("Compress::Zlib needs zlib version 1.x\n") ; { + /* Create the $os_code scalar */ + SV * os_code_sv = perl_get_sv("Compress::Zlib::gzip_os_code", GV_ADDMULTI) ; + sv_setiv(os_code_sv, GZIP_OS_CODE) ; + } + + { /* Create the $gzerror scalar */ SV * gzerror_sv = perl_get_sv(GZERRNO, GV_ADDMULTI) ; sv_setiv(gzerror_sv, 0) ; @@ -364,6 +698,48 @@ BOOT: } +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)) { + SvNVX(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 { + SvIVX(ST(0)) = SvIV(num); + SvIOK_on(ST(0)); + } + XSRETURN(1); +} + + #define Zip_zlib_version() (char*)zlib_version char* Zip_zlib_version() @@ -382,222 +758,8 @@ ZLIB_VERNUM() OUTPUT: RETVAL - - -void -DispStream(s, message=NULL) - Compress::Zlib::inflateStream s - char * message - -Compress::Zlib::gzFile -gzopen_(path, mode) - char * path - char * mode - CODE: - gzFile gz ; - gz = gzopen(path, mode) ; - if (gz) { - ZMALLOC(RETVAL, gzType) ; - RETVAL->buffer = newSV(SIZE) ; - SvPOK_only(RETVAL->buffer) ; - SvCUR_set(RETVAL->buffer, 0) ; - RETVAL->offset = 0 ; - RETVAL->gz = gz ; - RETVAL->closed = FALSE ; - SetGzErrorNo(0) ; - } - else { - RETVAL = NULL ; - SetGzErrorNo(errno ? Z_ERRNO : Z_MEM_ERROR) ; - } - OUTPUT: - RETVAL - - -Compress::Zlib::gzFile -gzdopen_(fh, mode, offset) - int fh - char * mode - long offset - CODE: - gzFile gz ; - if (offset != -1) - lseek(fh, offset, 0) ; - gz = gzdopen(fh, mode) ; - if (gz) { - ZMALLOC(RETVAL, gzType) ; - RETVAL->buffer = newSV(SIZE) ; - SvPOK_only(RETVAL->buffer) ; - SvCUR_set(RETVAL->buffer, 0) ; - RETVAL->offset = 0 ; - RETVAL->gz = gz ; - RETVAL->closed = FALSE ; - SetGzErrorNo(0) ; - } - else { - RETVAL = NULL ; - SetGzErrorNo(errno ? Z_ERRNO : Z_MEM_ERROR) ; - } - OUTPUT: - RETVAL - - -MODULE = Compress::Zlib PACKAGE = Compress::Zlib::gzFile PREFIX = Zip_ - -#define Zip_gzread(file, buf, len) gzread(file->gz, bufp, len) - -int -Zip_gzread(file, buf, len=4096) - Compress::Zlib::gzFile file - unsigned len - SV * buf - voidp bufp = NO_INIT - uLong bufsize = 0 ; - int RETVAL = 0 ; - CODE: - if (SvREADONLY(buf) && PL_curcop != &PL_compiling) - croak("gzread: buffer parameter is read-only"); - SvUPGRADE(buf, SVt_PV); - SvPOK_only(buf); - SvCUR_set(buf, 0); - /* any left over from gzreadline ? */ - if ((bufsize = SvCUR(file->buffer)) > 0) { - uLong movesize ; - - if (bufsize < len) { - movesize = bufsize ; - len -= movesize ; - } - else { - movesize = len ; - len = 0 ; - } - RETVAL = movesize ; - - sv_catpvn(buf, SvPVX(file->buffer) + file->offset, movesize); - - file->offset += movesize ; - SvCUR_set(file->buffer, bufsize - movesize) ; - } - - if (len) { - bufp = (Byte*)SvGROW(buf, bufsize+len+1); - RETVAL = gzread(file->gz, ((Bytef*)bufp)+bufsize, len) ; - SetGzError(file->gz) ; - if (RETVAL >= 0) { - RETVAL += bufsize ; - SvCUR_set(buf, RETVAL) ; - *SvEND(buf) = '\0'; - } - } - OUTPUT: - RETVAL - buf - -int -gzreadline(file, buf) - Compress::Zlib::gzFile file - SV * buf - int RETVAL = 0; - CODE: - if (SvREADONLY(buf) && PL_curcop != &PL_compiling) - croak("gzreadline: buffer parameter is read-only"); - SvUPGRADE(buf, SVt_PV); - SvPOK_only(buf); - /* sv_setpvn(buf, "", SIZE) ; */ - SvGROW(buf, SIZE) ; - SvCUR_set(buf, 0); - RETVAL = gzreadline(file, buf) ; - SetGzError(file->gz) ; - OUTPUT: - RETVAL - buf - CLEANUP: - if (RETVAL >= 0) { - /* SvCUR(buf) = RETVAL; */ - /* Don't need to explicitly terminate with '\0', because - sv_catpvn aready has */ - } - -#define Zip_gzwrite(file, buf) gzwrite(file->gz, buf, (unsigned)len) -int -Zip_gzwrite(file, buf) - Compress::Zlib::gzFile file - STRLEN len = NO_INIT - voidp buf = (voidp)SvPV(ST(1), len) ; - CLEANUP: - SetGzError(file->gz) ; - -#define Zip_gzflush(file, flush) gzflush(file->gz, flush) -int -Zip_gzflush(file, flush) - Compress::Zlib::gzFile file - int flush - CLEANUP: - SetGzError(file->gz) ; - -#define Zip_gzclose(file) file->closed ? 0 : gzclose(file->gz) -int -Zip_gzclose(file) - Compress::Zlib::gzFile file - CLEANUP: - file->closed = TRUE ; - SetGzErrorNo(RETVAL) ; - - -#define Zip_gzeof(file) gzeof(file->gz) -int -Zip_gzeof(file) - Compress::Zlib::gzFile file - CODE: -#ifdef OLD_ZLIB - croak("gzeof needs zlib 1.0.6 or better") ; -#else - RETVAL = gzeof(file->gz); -#endif - OUTPUT: - RETVAL - - -#define Zip_gzsetparams(file,l,s) gzsetparams(file->gz,l,s) -int -Zip_gzsetparams(file, level, strategy) - Compress::Zlib::gzFile file - int level - int strategy - CODE: -#ifdef OLD_ZLIB - croak("gzsetparams needs zlib 1.0.6 or better") ; -#else - RETVAL = gzsetparams(file->gz, level, strategy); -#endif - OUTPUT: - RETVAL - -void -DESTROY(file) - Compress::Zlib::gzFile file - CODE: - if (! file->closed) - Zip_gzclose(file) ; - SvREFCNT_dec(file->buffer) ; - safefree((char*)file) ; - -#define Zip_gzerror(file) (char*)gzerror(file->gz, &errnum) - -char * -Zip_gzerror(file) - Compress::Zlib::gzFile file - int errnum = NO_INIT - CLEANUP: - sv_setiv(ST(0), errnum) ; - SvPOK_on(ST(0)) ; - - - MODULE = Compress::Zlib PACKAGE = Compress::Zlib PREFIX = Zip_ - #define Zip_adler32(buf, adler) adler32(adler, buf, (uInt)len) uLong @@ -609,7 +771,11 @@ Zip_adler32(buf, adler=adlerInitial) INIT: /* If the buffer is a reference, dereference it */ sv = deRef(sv, "adler32") ; - buf = (Byte*)SvPV(sv, len) ; +#ifdef UTF8_AVAILABLE + if (DO_UTF8(sv) && !sv_utf8_downgrade(sv, 1)) + croak("Wide character in Compress::Zlib::adler32"); +#endif + buf = (Byte*)SvPVbyte(sv, len) ; if (items < 2) adler = adlerInitial; @@ -629,7 +795,11 @@ Zip_crc32(buf, crc=crcInitial) INIT: /* If the buffer is a reference, dereference it */ sv = deRef(sv, "crc32") ; - buf = (Byte*)SvPV(sv, len) ; +#ifdef UTF8_AVAILABLE + if (DO_UTF8(sv) && !sv_utf8_downgrade(sv, 1)) + croak("Wide character in Compress::Zlib::crc32"); +#endif + buf = (Byte*)SvPVbyte(sv, len) ; if (items < 2) crc = crcInitial; @@ -638,26 +808,59 @@ Zip_crc32(buf, crc=crcInitial) else crc = crcInitial; + +uLong +crc32_combine(crc1, crc2, len2) + uLong crc1 + uLong crc2 + z_off_t len2 + CODE: +#ifndef AT_LEAST_ZLIB_1_2_2_1 + crc1 = crc1; crc2 = crc2 ; len2 = len2; /* Silence -Wall */ + croak("crc32_combine needs zlib 1.2.3 or better"); +#else + RETVAL = crc32_combine(crc1, crc2, len2); +#endif + OUTPUT: + RETVAL + + +uLong +adler32_combine(adler1, adler2, len2) + uLong adler1 + uLong adler2 + z_off_t len2 + CODE: +#ifndef AT_LEAST_ZLIB_1_2_2_1 + adler1 = adler1; adler2 = adler2 ; len2 = len2; /* Silence -Wall */ + croak("adler32_combine needs zlib 1.2.3 or better"); +#else + RETVAL = adler32_combine(adler1, adler2, len2); +#endif + OUTPUT: + RETVAL + + MODULE = Compress::Zlib PACKAGE = Compress::Zlib void -_deflateInit(level, method, windowBits, memLevel, strategy, bufsize, dictionary) +_deflateInit(flags,level, method, windowBits, memLevel, strategy, bufsize, dictionary) + int flags int level int method int windowBits int memLevel int strategy uLong bufsize - SV * dictionary + SV* dictionary PPCODE: - int err ; deflateStream s ; if (trace) - warn("in _deflateInit(level=%d, method=%d, windowBits=%d, memLevel=%d, strategy=%d, bufsize=%d\n", + warn("in _deflateInit(level=%d, method=%d, windowBits=%d, memLevel=%d, strategy=%d, bufsize=%ld\n", level, method, windowBits, memLevel, strategy, bufsize) ; - if ((s = InitStream(bufsize)) ) { + if ((s = InitStream() )) { s->Level = level; s->Method = method; @@ -669,8 +872,13 @@ _deflateInit(level, method, windowBits, memLevel, strategy, bufsize, dictionary) method, windowBits, memLevel, strategy); /* Check if a dictionary has been specified */ + if (err == Z_OK && SvCUR(dictionary)) { - err = deflateSetDictionary(&(s->stream), (const Bytef*) SvPVX(dictionary), +#ifdef UTF8_AVAILABLE + if (DO_UTF8(dictionary) && !sv_utf8_downgrade(dictionary, 1)) + croak("Wide character in Compress::Zlib::Deflate::new dicrionary parameter"); +#endif + err = deflateSetDictionary(&(s->stream), (const Bytef*) SvPVbyte_nolen(dictionary), SvCUR(dictionary)) ; s->dict_adler = s->stream.adler ; } @@ -679,6 +887,8 @@ _deflateInit(level, method, windowBits, memLevel, strategy, bufsize, dictionary) Safefree(s) ; s = NULL ; } + else + PostInitStream(s, flags, bufsize, windowBits) ; } else @@ -686,28 +896,36 @@ _deflateInit(level, method, windowBits, memLevel, strategy, bufsize, dictionary) XPUSHs(sv_setref_pv(sv_newmortal(), "Compress::Zlib::deflateStream", (void*)s)); - if (GIMME == G_ARRAY) - XPUSHs(sv_2mortal(newSViv(err))) ; + if (GIMME == G_ARRAY) { + SV * sv = sv_2mortal(newSViv(err)) ; + setDUALstatus(sv, err); + XPUSHs(sv) ; + } void -_inflateInit(windowBits, bufsize, dictionary) +_inflateInit(flags, windowBits, bufsize, dictionary) + int flags int windowBits uLong bufsize SV * dictionary + ALIAS: + _inflateScanInit = 1 PPCODE: int err = Z_OK ; inflateStream s ; - +#ifndef MAGIC_APPEND + if (ix == 1) + croak("inflateScanInit needs zlib 1.2.1 or better"); +#endif if (trace) - warn("in _inflateInit(windowBits=%d, bufsize=%d, dictionary=%d\n", - windowBits, bufsize, SvCUR(dictionary)) ; - if ((s = InitStream(bufsize)) ) { + warn("in _inflateInit(windowBits=%d, bufsize=%lu, dictionary=%lu\n", + windowBits, bufsize, (unsigned long)SvCUR(dictionary)) ; + if ((s = InitStream() )) { s->WindowBits = windowBits; err = inflateInit2(&(s->stream), windowBits); - if (err != Z_OK) { Safefree(s) ; s = NULL ; @@ -716,14 +934,29 @@ _inflateInit(windowBits, bufsize, dictionary) /* Dictionary specified - take a copy for use in inflate */ s->dictionary = newSVsv(dictionary) ; } + if (s) { + PostInitStream(s, flags, bufsize, windowBits) ; +#ifdef MAGIC_APPEND + if (ix == 1) + { + s->window = (unsigned char *)safemalloc(WINDOW_SIZE); + } +#endif + } } else err = Z_MEM_ERROR ; XPUSHs(sv_setref_pv(sv_newmortal(), - "Compress::Zlib::inflateStream", (void*)s)); - if (GIMME == G_ARRAY) - XPUSHs(sv_2mortal(newSViv(err))) ; + ix == 1 + ? "Compress::Zlib::inflateScanStream" + : "Compress::Zlib::inflateStream", + (void*)s)); + if (GIMME == G_ARRAY) { + SV * sv = sv_2mortal(newSViv(err)) ; + setDUALstatus(sv, err); + XPUSHs(sv) ; + } @@ -731,35 +964,63 @@ MODULE = Compress::Zlib PACKAGE = Compress::Zlib::deflateStream void DispStream(s, message=NULL) - Compress::Zlib::deflateStream s - char * message + Compress::Zlib::deflateStream s + char * message + +DualType +deflateReset(s) + Compress::Zlib::deflateStream s + CODE: + RETVAL = deflateReset(&(s->stream)) ; + if (RETVAL == Z_OK) { + PostInitStream(s, s->flags, s->bufsize, s->WindowBits) ; + } + OUTPUT: + RETVAL -void -deflate (s, buf) +DualType +deflate (s, buf, output) Compress::Zlib::deflateStream s SV * buf - uLong outsize = NO_INIT - SV * output = NO_INIT - int err = 0; - PPCODE: - - /* If the buffer is a reference, dereference it */ + SV * output + uInt cur_length = NO_INIT + uInt increment = NO_INIT + int RETVAL = 0; + CODE: + + /* If the input buffer is a reference, dereference it */ buf = deRef(buf, "deflate") ; /* initialise the input buffer */ - s->stream.next_in = (Bytef*)SvPV(buf, *(STRLEN*)&s->stream.avail_in) ; - /* s->stream.next_in = (Bytef*)SvPVX(buf); */ - s->stream.avail_in = SvCUR(buf) ; - - /* and the output buffer */ - /* output = sv_2mortal(newSVpv("", s->bufinc)) ; */ - output = sv_2mortal(newSV(s->bufinc)) ; - SvPOK_only(output) ; - SvCUR_set(output, 0) ; - outsize = s->bufinc ; - s->stream.next_out = (Bytef*) SvPVX(output) ; - s->stream.avail_out = outsize; - +#ifdef UTF8_AVAILABLE + if (DO_UTF8(buf) && !sv_utf8_downgrade(buf, 1)) + croak("Wide character in Compress::Zlib::Deflate::deflate input parameter"); +#endif + s->stream.next_in = (Bytef*)SvPVbyte(buf, *(STRLEN*)&s->stream.avail_in) ; + /* s->stream.avail_in = SvCUR(buf) ; */ + + if (s->flags & FLAG_CRC32) + s->crc32 = crc32(s->crc32, s->stream.next_in, s->stream.avail_in) ; + + if (s->flags & FLAG_ADLER32) + s->adler32 = adler32(s->adler32, s->stream.next_in, s->stream.avail_in) ; + + /* and retrieve the output buffer */ + output = deRef_l(output, "deflate") ; +#ifdef UTF8_AVAILABLE + if (DO_UTF8(output) && !sv_utf8_downgrade(output, 1)) + croak("Wide character in Compress::Zlib::Deflate::deflate output parameter"); +#endif + + if((s->flags & FLAG_APPEND) != FLAG_APPEND) { + SvCUR_set(output, 0); + /* sv_setpvn(output, "", 0); */ + } + cur_length = SvCUR(output) ; + s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length; + increment = SvLEN(output) - cur_length; + s->stream.avail_out = increment; +#ifdef SETP_BYTE /* Check for saved output from deflateParams */ if (s->deflateParams_out_valid) { *(s->stream.next_out) = s->deflateParams_out_byte; @@ -767,52 +1028,93 @@ deflate (s, buf) -- s->stream.avail_out ; s->deflateParams_out_valid = FALSE; } - +#else + /* Check for saved output from deflateParams */ + if (s->deflateParams_out_length) { + uLong plen = s->deflateParams_out_length ; + /* printf("Copy %d bytes saved data\n", plen);*/ + if (s->stream.avail_out < plen) { + /*printf("GROW from %d to %d\n", s->stream.avail_out, + SvLEN(output) + plen - s->stream.avail_out); */ + Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ; + } + + Copy(s->stream.next_out, s->deflateParams_out_buffer, plen, Bytef) ; + cur_length = cur_length + plen; + SvCUR_set(output, cur_length); + s->stream.next_out += plen ; + s->stream.avail_out = SvLEN(output) - cur_length ; + increment = s->stream.avail_out; + s->deflateParams_out_length = 0; + } +#endif while (s->stream.avail_in != 0) { if (s->stream.avail_out == 0) { + /* out of space in the output buffer so make it bigger */ s->bufinc *= 2 ; - SvGROW(output, outsize + s->bufinc) ; - s->stream.next_out = (Bytef*) SvPVX(output) + outsize ; - outsize += s->bufinc ; - s->stream.avail_out = s->bufinc ; + 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; } - err = deflate(&(s->stream), Z_NO_FLUSH); - if (err != Z_OK) + + RETVAL = deflate(&(s->stream), Z_NO_FLUSH); + if (RETVAL != Z_OK) break; } - if (err == Z_OK) { + s->last_error = RETVAL ; + if (RETVAL == Z_OK) { SvPOK_only(output); - SvCUR_set(output, outsize - s->stream.avail_out) ; + SvCUR_set(output, cur_length + increment - s->stream.avail_out) ; } - else - output = &PL_sv_undef ; - XPUSHs(output) ; - if (GIMME == G_ARRAY) - XPUSHs(sv_2mortal(newSViv(err))) ; + OUTPUT: + RETVAL + output - void -flush(s, f=Z_FINISH) +DESTROY(s) Compress::Zlib::deflateStream s - int f - uLong outsize = NO_INIT - SV * output = NO_INIT - int err = Z_OK ; - PPCODE: + CODE: + deflateEnd(&s->stream) ; + if (s->dictionary) + SvREFCNT_dec(s->dictionary) ; +#ifndef SETP_BYTE + if (s->deflateParams_out_buffer) + Safefree(s->deflateParams_out_buffer); +#endif + Safefree(s) ; + + +DualType +flush(s, output, f=Z_FINISH) + Compress::Zlib::deflateStream s + SV * output + int f + uInt cur_length = NO_INIT + uInt increment = NO_INIT + CODE: s->stream.avail_in = 0; /* should be zero already anyway */ - /* output = sv_2mortal(newSVpv("", s->bufinc)) ; */ - output = sv_2mortal(newSV(s->bufinc)) ; - SvPOK_only(output) ; - SvCUR_set(output, 0) ; - outsize = s->bufinc ; - s->stream.next_out = (Bytef*) SvPVX(output) ; - s->stream.avail_out = outsize; - + /* retrieve the output buffer */ + output = deRef_l(output, "flush") ; +#ifdef UTF8_AVAILABLE + if (DO_UTF8(output) && !sv_utf8_downgrade(output, 1)) + croak("Wide character in Compress::Zlib::Deflate::flush input parameter"); +#endif + if(! s->flags & FLAG_APPEND) { + SvCUR_set(output, 0); + /* sv_setpvn(output, "", 0); */ + } + cur_length = SvCUR(output) ; + s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length; + increment = SvLEN(output) - cur_length; + s->stream.avail_out = increment; +#ifdef SETP_BYTE /* Check for saved output from deflateParams */ if (s->deflateParams_out_valid) { *(s->stream.next_out) = s->deflateParams_out_byte; @@ -820,38 +1122,59 @@ flush(s, f=Z_FINISH) -- s->stream.avail_out ; s->deflateParams_out_valid = FALSE; } +#else + /* Check for saved output from deflateParams */ + if (s->deflateParams_out_length) { + uLong plen = s->deflateParams_out_length ; + /* printf("Copy %d bytes saved data\n", plen); */ + if (s->stream.avail_out < plen) { + /* printf("GROW from %d to %d\n", s->stream.avail_out, + SvLEN(output) + plen - s->stream.avail_out); */ + Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ; + } + + Copy(s->stream.next_out, s->deflateParams_out_buffer, plen, Bytef) ; + cur_length = cur_length + plen; + SvCUR_set(output, cur_length); + s->stream.next_out += plen ; + s->stream.avail_out = SvLEN(output) - cur_length ; + increment = s->stream.avail_out; + s->deflateParams_out_length = 0; + } +#endif for (;;) { if (s->stream.avail_out == 0) { /* consumed all the available output, so extend it */ s->bufinc *= 2 ; - SvGROW(output, outsize + s->bufinc) ; - s->stream.next_out = (Bytef*)SvPVX(output) + outsize ; - outsize += s->bufinc ; - s->stream.avail_out = s->bufinc ; + 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; } - err = deflate(&(s->stream), f); + RETVAL = deflate(&(s->stream), f); /* deflate has finished flushing only when it hasn't used up * all the available space in the output buffer: */ - if (s->stream.avail_out != 0 || err != Z_OK ) + if (s->stream.avail_out != 0 || RETVAL != Z_OK ) break; } - err = (err == Z_STREAM_END ? Z_OK : err) ; + RETVAL = (RETVAL == Z_STREAM_END ? Z_OK : RETVAL) ; + s->last_error = RETVAL ; - if (err == Z_OK) { + if (RETVAL == Z_OK) { SvPOK_only(output); - SvCUR_set(output, outsize - s->stream.avail_out) ; + SvCUR_set(output, cur_length + increment - s->stream.avail_out) ; } - else - output = &PL_sv_undef ; - XPUSHs(output) ; - if (GIMME == G_ARRAY) - XPUSHs(sv_2mortal(newSViv(err))) ; + OUTPUT: + RETVAL + output -int + +DualType _deflateParams(s, flags, level, strategy, bufsize) Compress::Zlib::deflateStream s int flags @@ -859,20 +1182,39 @@ _deflateParams(s, flags, level, strategy, bufsize) int strategy uLong bufsize CODE: + /* printf("_deflateParams(Flags %d Level %d Strategy %d Bufsize %d)\n", flags, level, strategy, bufsize); + printf("Before -- Level %d, Strategy %d, Bufsize %d\n", s->Level, s->Strategy, s->bufsize); */ if (flags & 1) s->Level = level ; if (flags & 2) s->Strategy = strategy ; - if (bufsize) { + if (flags & 4) { s->bufsize = bufsize; s->bufinc = bufsize; } + /* printf("After -- Level %d, Strategy %d, Bufsize %d\n", s->Level, s->Strategy, s->bufsize);*/ +#ifdef SETP_BYTE s->stream.avail_in = 0; s->stream.next_out = &(s->deflateParams_out_byte) ; s->stream.avail_out = 1; RETVAL = deflateParams(&(s->stream), s->Level, s->Strategy); s->deflateParams_out_valid = (RETVAL == Z_OK && s->stream.avail_out == 0) ; + /* printf("RETVAL %d, avail out %d, byte %c\n", RETVAL, s->stream.avail_out, s->deflateParams_out_byte); */ +#else + /* printf("Level %d Strategy %d, Prev Len %d\n", + s->Level, s->Strategy, s->deflateParams_out_length); */ + s->stream.avail_in = 0; + if (s->deflateParams_out_buffer == NULL) + s->deflateParams_out_buffer = safemalloc(deflateParams_BUFFER_SIZE); + s->stream.next_out = s->deflateParams_out_buffer ; + s->stream.avail_out = deflateParams_BUFFER_SIZE; + + RETVAL = deflateParams(&(s->stream), s->Level, s->Strategy); + s->deflateParams_out_length = deflateParams_BUFFER_SIZE - s->stream.avail_out; + /* printf("RETVAL %d, length out %d, avail %d\n", + RETVAL, s->deflateParams_out_length, s->stream.avail_out ); */ +#endif OUTPUT: RETVAL @@ -893,15 +1235,31 @@ get_Strategy(s) OUTPUT: RETVAL -void -DESTROY(s) - Compress::Zlib::deflateStream s - CODE: - deflateEnd(&s->stream) ; - if (s->dictionary) - SvREFCNT_dec(s->dictionary) ; - Safefree(s) ; +uLong +get_Bufsize(s) + Compress::Zlib::deflateStream s + CODE: + RETVAL = s->bufsize ; + OUTPUT: + RETVAL + + +int +status(s) + Compress::Zlib::deflateStream s + CODE: + RETVAL = s->last_error ; + OUTPUT: + RETVAL + +uLong +crc32(s) + Compress::Zlib::deflateStream s + CODE: + RETVAL = s->crc32 ; + OUTPUT: + RETVAL uLong dict_adler(s) @@ -912,10 +1270,18 @@ dict_adler(s) RETVAL uLong +adler32(s) + Compress::Zlib::deflateStream s + CODE: + RETVAL = s->adler32 ; + OUTPUT: + RETVAL + +uLong total_in(s) Compress::Zlib::deflateStream s CODE: - RETVAL = s->stream.total_in ; + RETVAL = s->stream.total_in ; OUTPUT: RETVAL @@ -923,7 +1289,7 @@ uLong total_out(s) Compress::Zlib::deflateStream s CODE: - RETVAL = s->stream.total_out ; + RETVAL = s->stream.total_out ; OUTPUT: RETVAL @@ -931,99 +1297,173 @@ char* msg(s) Compress::Zlib::deflateStream s CODE: - RETVAL = s->stream.msg; + RETVAL = s->stream.msg; OUTPUT: RETVAL +int +deflateTune(s, good_length, max_lazy, nice_length, max_chain) + Compress::Zlib::deflateStream s + int good_length + int max_lazy + int nice_length + int max_chain + CODE: +#ifndef AT_LEAST_ZLIB_1_2_2_3 + good_length = good_length; max_lazy = max_lazy ; /* Silence -Wall */ + nice_length = nice_length; max_chain = max_chain; /* Silence -Wall */ + croak("deflateTune needs zlib 1.2.2.3 or better"); +#else + RETVAL = deflateTune(&(s->stream), good_length, max_lazy, nice_length, max_chain); +#endif + OUTPUT: + RETVAL + MODULE = Compress::Zlib PACKAGE = Compress::Zlib::inflateStream void DispStream(s, message=NULL) - Compress::Zlib::inflateStream s - char * message + Compress::Zlib::inflateStream s + char * message + +DualType +inflateReset(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = inflateReset(&(s->stream)) ; + if (RETVAL == Z_OK) { + PostInitStream(s, s->flags, s->bufsize, s->WindowBits) ; + } + OUTPUT: + RETVAL -void -inflate (s, buf) +DualType +inflate (s, buf, output) Compress::Zlib::inflateStream s SV * buf - uLong outsize = NO_INIT - SV * output = NO_INIT - int err = Z_OK ; - ALIAS: - __unc_inflate = 1 - PPCODE: - + SV * output + uInt cur_length = NO_INIT + uInt prefix_length = NO_INIT + uInt increment = NO_INIT + PREINIT: +#ifdef UTF8_AVAILABLE + bool out_utf8 = FALSE; +#endif + CODE: /* If the buffer is a reference, dereference it */ buf = deRef(buf, "inflate") ; + + if (s->flags & FLAG_CONSUME_INPUT && SvREADONLY(buf)) + croak("Compress::Zlib::Inflate::inflate input parameter cannot be read-only when ConsumeInput is specified"); +#ifdef UTF8_AVAILABLE + if (DO_UTF8(buf) && !sv_utf8_downgrade(buf, 1)) + croak("Wide character in Compress::Zlib::Inflate::inflate input parameter"); +#endif /* initialise the input buffer */ - s->stream.next_in = (Bytef*)SvPVX(buf) ; - s->stream.avail_in = SvCUR(buf) ; + s->stream.next_in = (Bytef*)SvPVbyte_force(buf, *(STRLEN*)&s->stream.avail_in) ; - /* and the output buffer */ - output = sv_2mortal(newSV(s->bufinc+1)) ; - SvPOK_only(output) ; - SvCUR_set(output, 0) ; - outsize = s->bufinc ; - s->stream.next_out = (Bytef*) SvPVX(output) ; - s->stream.avail_out = outsize; - + /* and retrieve the output buffer */ + output = deRef_l(output, "inflate") ; +#ifdef UTF8_AVAILABLE + if (DO_UTF8(output)) + out_utf8 = TRUE ; + if (DO_UTF8(output) && !sv_utf8_downgrade(output, 1)) + croak("Wide character in Compress::Zlib::Inflate::inflate output parameter"); +#endif + if((s->flags & FLAG_APPEND) != FLAG_APPEND) { + SvCUR_set(output, 0); + } + prefix_length = cur_length = SvCUR(output) ; + s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length; + increment = SvLEN(output) - cur_length; + s->stream.avail_out = increment; + s->bytesInflated = 0; + while (1) { if (s->stream.avail_out == 0) { + /* out of space in the output buffer so make it bigger */ s->bufinc *= 2 ; - SvGROW(output, outsize + s->bufinc+1) ; - s->stream.next_out = (Bytef*) SvPVX(output) + outsize ; - outsize += s->bufinc ; - s->stream.avail_out = s->bufinc ; + Sv_Grow(output, SvLEN(output) + s->bufinc + 1) ; + cur_length += increment ; + s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length ; + increment = s->bufinc ; + s->stream.avail_out = increment; } - err = inflate(&(s->stream), Z_SYNC_FLUSH); - if (err == Z_BUF_ERROR) { - if (s->stream.avail_out == 0) - continue ; - if (s->stream.avail_in == 0) { - err = Z_OK ; - break ; - } - } + RETVAL = inflate(&(s->stream), Z_SYNC_FLUSH); - if (err == Z_NEED_DICT && s->dictionary) { - s->dict_adler = s->stream.adler ; - err = inflateSetDictionary(&(s->stream), - (const Bytef*)SvPVX(s->dictionary), - SvCUR(s->dictionary)); - } - - if (err != Z_OK) + + if (RETVAL == Z_BUF_ERROR) { + if (s->stream.avail_out == 0) + continue ; + if (s->stream.avail_in == 0) { + RETVAL = Z_OK ; + break ; + } + } + + if (RETVAL == Z_NEED_DICT && s->dictionary) { + s->dict_adler = s->stream.adler ; + RETVAL = inflateSetDictionary(&(s->stream), + (const Bytef*)SvPVbyte_nolen(s->dictionary), + SvCUR(s->dictionary)); + } + + if (RETVAL != Z_OK) break; } - if (err == Z_OK || err == Z_STREAM_END || err == Z_DATA_ERROR) { + 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; SvPOK_only(output); - SvCUR_set(output, outsize - s->stream.avail_out) ; - *SvEND(output) = '\0'; - - /* fix the input buffer */ - if (ix == 0) { - in = s->stream.avail_in ; - SvCUR_set(buf, in) ; - if (in) - Move(s->stream.next_in, SvPVX(buf), in, char) ; + SvCUR_set(output, prefix_length + s->bytesInflated) ; + *SvEND(output) = '\0'; +#ifdef UTF8_AVAILABLE + if (out_utf8) + sv_utf8_upgrade(output); +#endif + + if (s->flags & FLAG_CRC32 ) + s->crc32 = crc32(s->crc32, + (const Bytef*)SvPVbyte_nolen(output)+prefix_length, + SvCUR(output)-prefix_length) ; + + if (s->flags & FLAG_ADLER32) + s->adler32 = adler32(s->adler32, + (const Bytef*)SvPVbyte_nolen(output)+prefix_length, + SvCUR(output)-prefix_length) ; + + /* fix the input buffer */ + if (s->flags & FLAG_CONSUME_INPUT) { + in = s->stream.avail_in ; + SvCUR_set(buf, in) ; + if (in) + Move(s->stream.next_in, SvPVbyte_nolen(buf), in, char) ; *SvEND(buf) = '\0'; SvSETMAGIC(buf); } } - else - output = &PL_sv_undef ; - XPUSHs(output) ; - if (GIMME == G_ARRAY) - XPUSHs(sv_2mortal(newSViv(err))) ; + OUTPUT: + RETVAL + buf + output -int +uLong +inflateCount(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = s->bytesInflated; + OUTPUT: + RETVAL + + +DualType inflateSync (s, buf) Compress::Zlib::inflateStream s SV * buf @@ -1031,9 +1471,13 @@ inflateSync (s, buf) /* If the buffer is a reference, dereference it */ buf = deRef(buf, "inflateSync") ; +#ifdef UTF8_AVAILABLE + if (DO_UTF8(buf) && !sv_utf8_downgrade(buf, 1)) + croak("Wide character in Compress::Zlib::Inflate::inflateSync"); +#endif /* initialise the input buffer */ - s->stream.next_in = (Bytef*)SvPVX(buf) ; + s->stream.next_in = (Bytef*)SvPVbyte_nolen(buf) ; s->stream.avail_in = SvCUR(buf) ; /* inflateSync doesn't create any output */ @@ -1041,18 +1485,20 @@ inflateSync (s, buf) s->stream.avail_out = 0; RETVAL = inflateSync(&(s->stream)); + s->last_error = RETVAL ; + + /* fix the input buffer */ { - /* fix the input buffer */ unsigned in = s->stream.avail_in ; - SvCUR_set(buf, in) ; if (in) - Move(s->stream.next_in, SvPVX(buf), in, char) ; + Move(s->stream.next_in, SvPVbyte_nolen(buf), in, char) ; *SvEND(buf) = '\0'; SvSETMAGIC(buf); } OUTPUT: RETVAL + buf void DESTROY(s) @@ -1061,10 +1507,34 @@ DESTROY(s) inflateEnd(&s->stream) ; if (s->dictionary) SvREFCNT_dec(s->dictionary) ; +#ifndef SETP_BYTE + if (s->deflateParams_out_buffer) + Safefree(s->deflateParams_out_buffer); +#endif +#ifdef MAGIC_APPEND + if (s->window) + Safefree(s->window); +#endif Safefree(s) ; uLong +status(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = s->last_error ; + OUTPUT: + RETVAL + +uLong +crc32(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = s->crc32 ; + OUTPUT: + RETVAL + +uLong dict_adler(s) Compress::Zlib::inflateStream s CODE: @@ -1076,7 +1546,15 @@ uLong total_in(s) Compress::Zlib::inflateStream s CODE: - RETVAL = s->stream.total_in ; + RETVAL = s->stream.total_in ; + OUTPUT: + RETVAL + +uLong +adler32(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = s->adler32 ; OUTPUT: RETVAL @@ -1084,7 +1562,7 @@ uLong total_out(s) Compress::Zlib::inflateStream s CODE: - RETVAL = s->stream.total_out ; + RETVAL = s->stream.total_out ; OUTPUT: RETVAL @@ -1092,8 +1570,328 @@ char* msg(s) Compress::Zlib::inflateStream s CODE: - RETVAL = s->stream.msg; + RETVAL = s->stream.msg; + OUTPUT: + RETVAL + + +uLong +get_Bufsize(s) + Compress::Zlib::inflateStream s + CODE: + RETVAL = s->bufsize ; OUTPUT: RETVAL +bool +set_Append(s, mode) + Compress::Zlib::inflateStream s + bool mode + CODE: + RETVAL = ((s->flags & FLAG_APPEND) == FLAG_APPEND); + if (mode) + s->flags |= FLAG_APPEND ; + else + s->flags &= ~FLAG_APPEND ; + OUTPUT: + RETVAL + +MODULE = Compress::Zlib PACKAGE = Compress::Zlib::inflateScanStream + +void +DESTROY(s) + Compress::Zlib::inflateScanStream s + CODE: + inflateEnd(&s->stream) ; + if (s->dictionary) + SvREFCNT_dec(s->dictionary) ; +#ifndef SETP_BYTE + if (s->deflateParams_out_buffer) + Safefree(s->deflateParams_out_buffer); +#endif +#ifdef MAGIC_APPEND + if (s->window) + Safefree(s->window); +#endif + Safefree(s) ; + +void +DispStream(s, message=NULL) + Compress::Zlib::inflateScanStream s + char * message + +DualType +scan(s, buf, out=NULL) + Compress::Zlib::inflateScanStream s + SV * buf + SV * out + int start_len = NO_INIT + ALIAS: + inflate = 1 + 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"); +#else + buf = deRef(buf, "inflateScan") ; +#ifdef UTF8_AVAILABLE + 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, *(STRLEN*)&s->stream.avail_in) ; + start_len = s->stream.avail_in ; + s->bytesInflated = 0 ; + do + { + if (s->stream.avail_in == 0) { + RETVAL = Z_OK ; + break ; + } + + /* set up output to next available section of sliding window */ + s->stream.avail_out = WINDOW_SIZE - s->window_have; + s->stream.next_out = s->window + s->window_have; + + /* DispStream(s, "before inflate\n"); */ + + /* inflate and check for errors */ + RETVAL = inflate(&(s->stream), Z_BLOCK); + + + if (start_len > 1) + s->window_lastByte = *(s->stream.next_in - 1 ) ; + + if (RETVAL == Z_STREAM_ERROR || RETVAL == Z_MEM_ERROR || + RETVAL == Z_DATA_ERROR ) + break ; + + if (s->flags & FLAG_CRC32 ) + s->crc32 = crc32(s->crc32, s->window + s->window_have, + WINDOW_SIZE - s->window_have - s->stream.avail_out); + + if (s->flags & FLAG_ADLER32) + s->adler32 = adler32(s->adler32, s->window + s->window_have, + WINDOW_SIZE - s->window_have - s->stream.avail_out); + + s->bytesInflated += WINDOW_SIZE - s->window_have - s->stream.avail_out; + + if (s->stream.avail_out) + s->window_have = WINDOW_SIZE - s->stream.avail_out; + else { + s->window_have = 0; + s->window_full = 1; + } + + /* process end of block */ + if (s->stream.data_type & 128) { + if (s->stream.data_type & 64) { + s->window_left = s->stream.data_type & 0x1f; + } + else { + s->window_lastbit = s->stream.data_type & 0x1f; + s->lastBlockOffset = s->stream.total_in; + } + } + + } while (RETVAL != Z_STREAM_END); + + s->last_error = RETVAL ; + s->window_lastoff = s->stream.total_in ; + + if (RETVAL == Z_STREAM_END) + { + s->matchedEndBlock = 1 ; + + /* save the location of the end of the compressed data */ + s->window_end = SvCUR(buf) - s->stream.avail_in - 1 ; + s->window_endOffset = s->stream.total_in ; + if (s->window_left) + { + -- s->window_endOffset ; + } + + /* if window wrapped, build dictionary from window by rotating */ + if (s->window_full) { + rotate(s->window, WINDOW_SIZE, s->window_have); + s->window_have = WINDOW_SIZE; + } + + /* if (s->flags & FLAG_CONSUME_INPUT) { */ + if (1) { + unsigned in = s->stream.avail_in ; + SvCUR_set(buf, in) ; + if (in) + Move(s->stream.next_in, SvPVbyte_nolen(buf), in, char) ; + *SvEND(buf) = '\0'; + SvSETMAGIC(buf); + } + } +#endif + OUTPUT: + RETVAL + + +uLong +getEndOffset(s) + Compress::Zlib::inflateScanStream s + CODE: +#ifndef MAGIC_APPEND + croak("getEndOffset needs zlib 1.2.1 or better"); +#else + RETVAL = s->window_endOffset; +#endif + OUTPUT: + RETVAL + +uLong +inflateCount(s) + Compress::Zlib::inflateScanStream s + CODE: +#ifndef MAGIC_APPEND + croak("inflateCount needs zlib 1.2.1 or better"); +#else + RETVAL = s->bytesInflated; +#endif + OUTPUT: + RETVAL + + +uLong +getLastBlockOffset(s) + Compress::Zlib::inflateScanStream s + CODE: +#ifndef MAGIC_APPEND + croak("getLastBlockOffset needs zlib 1.2.1 or better"); +#else + RETVAL = s->lastBlockOffset - (s->window_lastbit != 0); +#endif + OUTPUT: + RETVAL + +uLong +getLastBufferOffset(s) + Compress::Zlib::inflateScanStream s + CODE: +#ifndef MAGIC_APPEND + croak("getLastBufferOffset needs zlib 1.2.1 or better"); +#else + RETVAL = s->window_lastoff; +#endif + OUTPUT: + RETVAL + +void +resetLastBlockByte(s, byte) + Compress::Zlib::inflateScanStream s + unsigned char* byte + CODE: +#ifndef MAGIC_APPEND + croak("resetLastBlockByte needs zlib 1.2.1 or better"); +#else + *byte = *byte ^ (1 << ((8 - s->window_lastbit) & 7)); +#endif + + +void +_createDeflateStream(inf_s, flags,level, method, windowBits, memLevel, strategy, bufsize) + Compress::Zlib::inflateScanStream inf_s + int flags + int level + int method + int windowBits + int memLevel + int strategy + uLong bufsize + PPCODE: + { +#ifndef MAGIC_APPEND + flags = flags; + level = level ; + method = method; + windowBits = windowBits; + memLevel = memLevel; + strategy = strategy; + bufsize= bufsize; + croak("_createDeflateStream needs zlib 1.2.1 or better"); +#else + int err ; + deflateStream s ; + + if (trace) + warn("in _createDeflateStream(level=%d, method=%d, windowBits=%d, memLevel=%d, strategy=%d, bufsize=%lu\n", + level, method, windowBits, memLevel, strategy, bufsize) ; + if ((s = InitStream() )) { + + s->Level = level; + s->Method = method; + s->WindowBits = windowBits; + s->MemLevel = memLevel; + s->Strategy = strategy; + + err = deflateInit2(&(s->stream), level, + method, windowBits, memLevel, strategy); + + if (err == Z_OK) { + err = deflateSetDictionary(&(s->stream), inf_s->window, inf_s->window_have); + s->dict_adler = s->stream.adler ; + } + + if (err != Z_OK) { + Safefree(s) ; + s = NULL ; + } + else { + PostInitStream(s, flags, bufsize, windowBits) ; + s->crc32 = inf_s->crc32; + s->adler32 = inf_s->adler32; + s->stream.adler = inf_s->stream.adler ; + /* s->stream.total_out = inf_s->bytesInflated ; */ + s->stream.total_in = inf_s->stream.total_out ; + if (inf_s->window_left) { + /* printf("** window_left %d, window_lastByte %d\n", inf_s->window_left, inf_s->window_lastByte); */ + deflatePrime(&(s->stream), 8 - inf_s->window_left, inf_s->window_lastByte); + } + } + } + else + err = Z_MEM_ERROR ; + + XPUSHs(sv_setref_pv(sv_newmortal(), + "Compress::Zlib::deflateStream", (void*)s)); + if (GIMME == G_ARRAY) { + SV * sv = sv_2mortal(newSViv(err)) ; + setDUALstatus(sv, err); + XPUSHs(sv) ; + } +#endif + } + +DualType +status(s) + Compress::Zlib::inflateScanStream s + CODE: + RETVAL = s->last_error ; + OUTPUT: + RETVAL + +uLong +crc32(s) + Compress::Zlib::inflateScanStream s + CODE: + RETVAL = s->crc32 ; + OUTPUT: + RETVAL + + +uLong +adler32(s) + Compress::Zlib::inflateScanStream s + CODE: + RETVAL = s->adler32 ; + OUTPUT: + RETVAL diff --git a/ext/Compress/Zlib/config.in b/ext/Compress/Zlib/config.in index 638d0761bb..c56cc03099 100755 --- a/ext/Compress/Zlib/config.in +++ b/ext/Compress/Zlib/config.in @@ -1,21 +1,27 @@ # Filename: config.in # # written by Paul Marquess <pmqs@cpan.org> -# last modified 18th July 2005 -# version 1.35 +# last modified 28th October 2003 +# version 2.000 # # # This file is used to control which zlib library will be used by # Compress::Zlib # -# See to the section "Controlling the version of zlib used by -# Compress::Zlib" in the README file for details of how to use this file. +# See to the sections below in the README file for details of how to +# use this file. +# +# Controlling the version of zlib used by Compress::Zlib +# +# Setting the Gzip OS Code +# -BUILD_ZLIB = True -INCLUDE = ./zlib-src -LIB = ./zlib-src -OLD_ZLIB = False +BUILD_ZLIB = True +INCLUDE = ./zlib-src +LIB = ./zlib-src +OLD_ZLIB = False +GZIP_OS_CODE = AUTO_DETECT # end of file config.in diff --git a/ext/Compress/Zlib/examples/filtdef b/ext/Compress/Zlib/examples/filtdef index 57dfeb9068..71e54daf93 100755 --- a/ext/Compress/Zlib/examples/filtdef +++ b/ext/Compress/Zlib/examples/filtdef @@ -1,29 +1,27 @@ #!/usr/local/bin/perl +use Compress::Zlib 2 ; + use strict ; use warnings ; -use Compress::Zlib ; - binmode STDIN; binmode STDOUT; -my $x = deflateInit() + +my $x = new Compress::Zlib::Deflate() or die "Cannot create a deflation stream\n" ; -my ($output, $status) ; +my $output = '' ; + while (<>) { - ($output, $status) = $x->deflate($_) ; - - $status == Z_OK - or die "deflation failed\n" ; + $x->deflate($_, $output) == Z_OK + or die "deflate failed\n" ; print $output ; } -($output, $status) = $x->flush() ; - -$status == Z_OK - or die "deflation failed\n" ; +$x->flush($output) == Z_OK + or die "flush failed\n" ; print $output ; diff --git a/ext/Compress/Zlib/examples/filtinf b/ext/Compress/Zlib/examples/filtinf index 1df202b1d7..bbac2c269b 100755 --- a/ext/Compress/Zlib/examples/filtinf +++ b/ext/Compress/Zlib/examples/filtinf @@ -1,21 +1,23 @@ #!/usr/local/bin/perl +use Compress::Zlib 2 ; + use strict ; use warnings ; -use Compress::Zlib ; +binmode STDIN; +binmode STDOUT; -my $x = inflateInit() +my $x = new Compress::Zlib::Inflate or die "Cannot create a inflation stream\n" ; my $input = '' ; -binmode STDIN; -binmode STDOUT; +my $output = '' ; +my $status ; -my ($output, $status) ; while (read(STDIN, $input, 4096)) { - ($output, $status) = $x->inflate(\$input) ; + $status = $x->inflate($input, $output) ; print $output if $status == Z_OK or $status == Z_STREAM_END ; diff --git a/ext/Compress/Zlib/examples/gzcat b/ext/Compress/Zlib/examples/gzcat index 3bbd2972c9..5572bae959 100755 --- a/ext/Compress/Zlib/examples/gzcat +++ b/ext/Compress/Zlib/examples/gzcat @@ -1,30 +1,29 @@ #!/usr/local/bin/perl +use IO::Uncompress::Gunzip qw( $GunzipError ); use strict ; use warnings ; -use Compress::Zlib ; - #die "Usage: gzcat file...\n" # unless @ARGV ; -my $filename ; +my $file ; +my $buffer ; +my $s; @ARGV = '-' unless @ARGV ; -foreach my $filename (@ARGV) { - my $buffer ; - - my $file = $filename ; - $file = \*STDIN if $file eq '-' ; - - my $gz = gzopen($file, "rb") - or die "Cannot open $file: $gzerrno\n" ; +foreach $file (@ARGV) { + + my $gz = new IO::Uncompress::Gunzip $file + or die "Cannot open $file: $GunzipError\n" ; - print $buffer while $gz->gzread($buffer) > 0 ; + print $buffer + while ($s = $gz->read($buffer)) > 0 ; - die "Error reading from $filename: $gzerrno" . ($gzerrno+0) . "\n" - if $gzerrno != Z_STREAM_END ; + die "Error reading from $file: $GunzipError\n" + if $s < 0 ; - $gz->gzclose() ; + $gz->close() ; } + diff --git a/ext/Compress/Zlib/examples/gzcat.zlib b/ext/Compress/Zlib/examples/gzcat.zlib new file mode 100644 index 0000000000..5ccb7001d0 --- /dev/null +++ b/ext/Compress/Zlib/examples/gzcat.zlib @@ -0,0 +1,25 @@ +#!/usr/local/bin/perl + +use Compress::Zlib ; +use strict ; +use warnings ; + +#die "Usage: gzcat file...\n" +# unless @ARGV ; + +my $file ; +my $buffer ; + +@ARGV = '-' unless @ARGV ; + +foreach $file (@ARGV) { + my $gz = gzopen($file, "rb") + or die "Cannot open $file: $gzerrno\n" ; + + print $buffer while $gz->gzread($buffer) > 0 ; + + die "Error reading from $file: $gzerrno" . ($gzerrno+0) . "\n" + if $gzerrno != Z_STREAM_END ; + + $gz->gzclose() ; +} diff --git a/ext/Compress/Zlib/examples/gzgrep b/ext/Compress/Zlib/examples/gzgrep index 324d3e615f..33820ba064 100755 --- a/ext/Compress/Zlib/examples/gzgrep +++ b/ext/Compress/Zlib/examples/gzgrep @@ -1,17 +1,30 @@ -#!/usr/local/bin/perl +#!/usr/bin/perl use strict ; use warnings ; +use IO::Uncompress::Gunzip qw($GunzipError); -use Compress::Zlib ; - -die "Usage: gzgrep pattern file...\n" - unless @ARGV >= 2; +die "Usage: gzgrep pattern [file...]\n" + unless @ARGV >= 1; my $pattern = shift ; - my $file ; +@ARGV = '-' unless @ARGV ; + +foreach $file (@ARGV) { + my $gz = new IO::Uncompress::Gunzip $file + or die "Cannot uncompress $file: $GunzipError\n" ; + + while (<$gz>) { + print if /$pattern/ ; + } + + die "Error reading from $file: $GunzipError\n" + if $GunzipError ; +} + +__END__ foreach $file (@ARGV) { my $gz = gzopen($file, "rb") or die "Cannot open $file: $gzerrno\n" ; diff --git a/ext/Compress/Zlib/examples/gzstream b/ext/Compress/Zlib/examples/gzstream index cb03a2c0fc..9d03bc5749 100755 --- a/ext/Compress/Zlib/examples/gzstream +++ b/ext/Compress/Zlib/examples/gzstream @@ -2,17 +2,23 @@ use strict ; use warnings ; +use IO::Compress::Gzip qw(gzip $GzipError); -use Compress::Zlib ; +gzip '-' => '-', Minimal => 1 + or die "gzstream: $GzipError\n" ; -binmode STDOUT; # gzopen only sets it on the fd +#exit 0; -my $gz = gzopen(\*STDOUT, "wb") - or die "Cannot open stdout: $gzerrno\n" ; +__END__ + +#my $gz = new IO::Compress::Gzip *STDOUT +my $gz = new IO::Compress::Gzip '-' + or die "gzstream: Cannot open stdout as gzip stream: $GzipError\n" ; while (<>) { - $gz->gzwrite($_) - or die "error writing: $gzerrno\n" ; + $gz->write($_) + or die "gzstream: Error writing gzip output stream: $GzipError\n" ; } -$gz->gzclose ; +$gz->close + or die "gzstream: Error closing gzip output stream: $GzipError\n" ; diff --git a/ext/Compress/Zlib/fallback.h b/ext/Compress/Zlib/fallback/constants.h index 2aef05e1ad..323f2367b7 100644 --- a/ext/Compress/Zlib/fallback.h +++ b/ext/Compress/Zlib/fallback/constants.h @@ -24,12 +24,23 @@ static int constant_7 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. - OS_CODE Z_ASCII Z_ERRNO */ - /* Offset 5 gives the best switch position. */ - switch (name[5]) { + OS_CODE Z_ASCII Z_BLOCK Z_ERRNO Z_FIXED */ + /* Offset 6 gives the best switch position. */ + switch (name[6]) { case 'D': - if (memEQ(name, "OS_CODE", 7)) { - /* ^ */ + if (memEQ(name, "Z_FIXE", 6)) { + /* D */ +#ifdef Z_FIXED + *iv_return = Z_FIXED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "OS_COD", 6)) { + /* E */ #ifdef OS_CODE *iv_return = OS_CODE; return PERL_constant_ISIV; @@ -39,8 +50,8 @@ constant_7 (pTHX_ const char *name, IV *iv_return) { } break; case 'I': - if (memEQ(name, "Z_ASCII", 7)) { - /* ^ */ + if (memEQ(name, "Z_ASCI", 6)) { + /* I */ #ifdef Z_ASCII *iv_return = Z_ASCII; return PERL_constant_ISIV; @@ -49,9 +60,20 @@ constant_7 (pTHX_ const char *name, IV *iv_return) { #endif } break; - case 'N': - if (memEQ(name, "Z_ERRNO", 7)) { - /* ^ */ + case 'K': + if (memEQ(name, "Z_BLOC", 6)) { + /* K */ +#ifdef Z_BLOCK + *iv_return = Z_BLOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "Z_ERRN", 6)) { + /* O */ #ifdef Z_ERRNO *iv_return = Z_ERRNO; return PERL_constant_ISIV; @@ -287,16 +309,16 @@ constant (pTHX_ const char *name, STRLEN len, IV *iv_return, const char **pv_ret Regenerate these constant functions by feeding this entire source file to perl -x -#!/home/paul/perl/install/redhat6.1/bleed/bin/perl5.7.2 -w +#!/usr/bin/perl5.8.6 -w use ExtUtils::Constant qw (constant_types C_constant XS_constant); my $types = {map {($_, 1)} qw(IV PV)}; my @names = (qw(DEF_WBITS MAX_MEM_LEVEL MAX_WBITS OS_CODE Z_ASCII - Z_BEST_COMPRESSION Z_BEST_SPEED Z_BINARY Z_BUF_ERROR + Z_BEST_COMPRESSION Z_BEST_SPEED Z_BINARY Z_BLOCK Z_BUF_ERROR Z_DATA_ERROR Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY Z_DEFLATED - Z_ERRNO Z_FILTERED Z_FINISH Z_FULL_FLUSH Z_HUFFMAN_ONLY + Z_ERRNO Z_FILTERED Z_FINISH Z_FIXED Z_FULL_FLUSH Z_HUFFMAN_ONLY Z_MEM_ERROR Z_NEED_DICT Z_NO_COMPRESSION Z_NO_FLUSH Z_NULL Z_OK - Z_PARTIAL_FLUSH Z_STREAM_END Z_STREAM_ERROR Z_SYNC_FLUSH + Z_PARTIAL_FLUSH Z_RLE Z_STREAM_END Z_STREAM_ERROR Z_SYNC_FLUSH Z_UNKNOWN Z_VERSION_ERROR), {name=>"ZLIB_VERSION", type=>"PV"}); @@ -320,6 +342,16 @@ __END__ #endif } break; + case 5: + if (memEQ(name, "Z_RLE", 5)) { +#ifdef Z_RLE + *iv_return = Z_RLE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; case 6: if (memEQ(name, "Z_NULL", 6)) { #ifdef Z_NULL diff --git a/ext/Compress/Zlib/fallback.xs b/ext/Compress/Zlib/fallback/constants.xs index 02a6ef436d..02a6ef436d 100644 --- a/ext/Compress/Zlib/fallback.xs +++ b/ext/Compress/Zlib/fallback/constants.xs diff --git a/ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm b/ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm new file mode 100644 index 0000000000..358dfaa8ff --- /dev/null +++ b/ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm @@ -0,0 +1,137 @@ +package Compress::Gzip::Constants; + +use strict ; +use warnings; +use bytes; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); +our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE); + +$VERSION = '2.000_05'; + +@ISA = qw(Exporter); + +@EXPORT= qw( + + GZIP_ID_SIZE + GZIP_ID1 + GZIP_ID2 + + GZIP_FLG_DEFAULT + GZIP_FLG_FTEXT + GZIP_FLG_FHCRC + GZIP_FLG_FEXTRA + GZIP_FLG_FNAME + GZIP_FLG_FCOMMENT + GZIP_FLG_RESERVED + + GZIP_CM_DEFLATED + + GZIP_MIN_HEADER_SIZE + GZIP_TRAILER_SIZE + + GZIP_MTIME_DEFAULT + GZIP_XFL_DEFAULT + GZIP_FEXTRA_HEADER_SIZE + GZIP_FEXTRA_MAX_SIZE + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE + GZIP_FEXTRA_SUBFIELD_ID_SIZE + GZIP_FEXTRA_SUBFIELD_LEN_SIZE + GZIP_FEXTRA_SUBFIELD_MAX_SIZE + + $GZIP_FNAME_INVALID_CHAR_RE + $GZIP_FCOMMENT_INVALID_CHAR_RE + + GZIP_FHCRC_SIZE + + GZIP_ISIZE_MAX + GZIP_ISIZE_MOD_VALUE + + + GZIP_NULL_BYTE + + GZIP_OS_DEFAULT + + %GZIP_OS_Names + + GZIP_MINIMUM_HEADER + + ); + +# Constant names derived from RFC 1952 + +use constant GZIP_ID_SIZE => 2 ; +use constant GZIP_ID1 => 0x1F; +use constant GZIP_ID2 => 0x8B; + +use constant GZIP_MIN_HEADER_SIZE => 10 ;# minimum gzip header size +use constant GZIP_TRAILER_SIZE => 8 ; + + +use constant GZIP_FLG_DEFAULT => 0x00 ; +use constant GZIP_FLG_FTEXT => 0x01 ; +use constant GZIP_FLG_FHCRC => 0x02 ; # called CONTINUATION in gzip +use constant GZIP_FLG_FEXTRA => 0x04 ; +use constant GZIP_FLG_FNAME => 0x08 ; +use constant GZIP_FLG_FCOMMENT => 0x10 ; +#use constant GZIP_FLG_ENCRYPTED => 0x20 ; # documented in gzip sources +use constant GZIP_FLG_RESERVED => (0x20 | 0x40 | 0x80) ; + +use constant GZIP_XFL_DEFAULT => 0x00 ; + +use constant GZIP_MTIME_DEFAULT => 0x00 ; + +use constant GZIP_FEXTRA_HEADER_SIZE => 2 ; +use constant GZIP_FEXTRA_MAX_SIZE => 0xFF ; +use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ; +use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ; +use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => GZIP_FEXTRA_SUBFIELD_ID_SIZE + + GZIP_FEXTRA_SUBFIELD_LEN_SIZE; +use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => GZIP_FEXTRA_MAX_SIZE - + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE ; + + $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x1F\x7F-\x9F]'; + $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x09\x11-\x1F\x7F-\x9F]'; + +use constant GZIP_FHCRC_SIZE => 2 ; # aka CONTINUATION in gzip + +use constant GZIP_CM_DEFLATED => 8 ; + +use constant GZIP_NULL_BYTE => "\x00"; +use constant GZIP_ISIZE_MAX => 0xFFFFFFFF ; +use constant GZIP_ISIZE_MOD_VALUE => GZIP_ISIZE_MAX + 1 ; + +# OS Names sourced from http://www.gzip.org/format.txt + +use constant GZIP_OS_DEFAULT=> 0xFF ; +%GZIP_OS_Names = ( + 0 => 'MS-DOS', + 1 => 'Amiga', + 2 => 'VMS', + 3 => 'Unix', + 4 => 'VM/CMS', + 5 => 'Atari TOS', + 6 => 'HPFS (OS/2, NT)', + 7 => 'Macintosh', + 8 => 'Z-System', + 9 => 'CP/M', + 10 => 'TOPS-20', + 11 => 'NTFS (NT)', + 12 => 'SMS QDOS', + 13 => 'Acorn RISCOS', + 14 => 'VFAT file system (Win95, NT)', + 15 => 'MVS', + 16 => 'BeOS', + 17 => 'Tandem/NSK', + 18 => 'THEOS', + GZIP_OS_DEFAULT() => 'Unknown', + ) ; + +use constant GZIP_MINIMUM_HEADER => pack("C4 V C C", + GZIP_ID1, GZIP_ID2, GZIP_CM_DEFLATED, GZIP_FLG_DEFAULT, + GZIP_MTIME_DEFAULT, GZIP_XFL_DEFAULT, GZIP_OS_DEFAULT) ; + + +1; diff --git a/ext/Compress/Zlib/lib/Compress/Zlib/Common.pm b/ext/Compress/Zlib/lib/Compress/Zlib/Common.pm new file mode 100644 index 0000000000..1106105a35 --- /dev/null +++ b/ext/Compress/Zlib/lib/Compress/Zlib/Common.pm @@ -0,0 +1,421 @@ +package Compress::Zlib::Common; + +use strict ; +use warnings; +use bytes; + +use Carp; +use Scalar::Util qw(blessed readonly); +use File::GlobMapper; + +require Exporter; +our ($VERSION, @ISA, @EXPORT); +@ISA = qw(Exporter); +$VERSION = '2.000_05'; + +@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput ckInputParam + isaFileGlobString cleanFileGlobString oneTarget + setBinModeInput setBinModeOutput + ckOutputParam ckInOutParams + WANT_CODE + WANT_EXT + WANT_UNDEF + WANT_HASH + ); + +sub setBinModeInput($) +{ + my $handle = shift ; + + #binmode $handle if $] == 5.008 ; + #binmode $handle unless isSTDIN($handle) ; +} + +sub setBinModeOutput($) +{ + my $handle = shift ; + + #binmode $handle if $] == 5.008; + #binmode $handle unless isSTDOUT($handle) ; +} + +#sub isSTDIO($) +#{ +# my $handle = shift ; +# +# return 0 unless isaFilehandle($handle); +# return fileno $handle == fileno STDIN || fileno $handle == fileno STDOUT; +#} +# +#sub isSTDIN($) +#{ +# my $handle = shift ; +# +# return 0 unless isaFilehandle($handle); +# return fileno $handle == fileno STDIN; +#} +# +#sub isSTDOUT($) +#{ +# my $handle = shift ; +# +# return 0 unless isaFilehandle($handle); +# return fileno $handle == fileno STDOUT; +#} + +sub isaFilehandle($) +{ + use utf8; # Pragma needed to keep Perl 5.6.0 happy + return (defined $_[0] and + (UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa(\$_[0],'GLOB')) + and defined fileno($_[0]) ) +} + +sub isaFilename($) +{ + return (defined $_[0] and + ! ref $_[0] and + UNIVERSAL::isa(\$_[0], 'SCALAR')); +} + +sub isaFileGlobString +{ + return defined $_[0] && $_[0] =~ /^<.*>$/; +} + +sub cleanFileGlobString +{ + my $string = shift ; + + $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; + + return $string; +} + +use constant WANT_CODE => 1 ; +use constant WANT_EXT => 2 ; +use constant WANT_UNDEF => 4 ; +use constant WANT_HASH => 8 ; + +sub whatIsInput($;$) +{ + my $got = whatIs(@_); + #return $got; + if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') + { + use IO::File; + $got = 'handle'; + #$_[0] = \*STDIN; + $_[0] = new IO::File("<-"); + } + + return $got; +} + +sub whatIsOutput($;$) +{ + my $got = whatIs(@_); + #return $got; + if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') + { + $got = 'handle'; + #$_[0] = \*STDOUT; + $_[0] = new IO::File(">-"); + } + + return $got; +} + +sub whatIs ($;$) +{ + return 'handle' if isaFilehandle($_[0]); + + my $wantCode = defined $_[1] && $_[1] & WANT_CODE ; + my $extended = defined $_[1] && $_[1] & WANT_EXT ; + my $undef = defined $_[1] && $_[1] & WANT_UNDEF ; + my $hash = defined $_[1] && $_[1] & WANT_HASH ; + + return 'undef' if ! defined $_[0] && $undef ; + + if (ref $_[0]) { + return '' if blessed($_[0]); # is an object + #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object + return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR'); + return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ; + return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ; + return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ; + return ''; + } + + return 'fileglob' if $extended && isaFileGlobString($_[0]); + return 'filename'; +} + +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 ckInOutParams($$$$) +#{ +# my $from = shift ; +# +# ckInputParam($from, $_[0], $_[2]) +# or return undef ; +# ckOutputParam($from, $_[1], $_[2]) +# or return undef ; +# +# my $inType = whatIs($_[0]); +# my $outType = whatIs($_[1]); +# +# # Check that input != output +# if ($inType eq $outType && $_[0] eq $_[1]) +# { +# local $Carp::CarpLevel = 1; +# croak("$from: input and output $inType are identical"); +# } +# +# 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, + ) ; + + my $obj = bless \%data, $class ; + + local $Carp::CarpLevel = 1; + + my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH); + my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH); + + my $oneInput = $data{oneInput} = oneTarget($inType); + my $oneOutput = $data{oneOutput} = oneTarget($outType); + + if (! $inType) + { + croak "$reportClass: illegal input parameter" ; + #return undef ; + } + + if ($inType eq 'hash') + { + $obj->{Hash} = 1 ; + $obj->{oneInput} = 1 ; + return $obj->validateHash($_[0]); + } + + if (! $outType) + { + croak "$reportClass: illegal output parameter" ; + #return undef ; + } + + + if ($inType ne 'fileglob' && $outType eq 'fileglob') + { + ${ $data{Error} } = "Need input fileglob for outout fileglob"; + return undef ; + } + + 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 eq 'fileglob' && $outType eq 'fileglob') + { + $data{GlobMap} = 1 ; + $data{inType} = $data{outType} = 'filename'; + my $mapper = new File::GlobMapper($_[0], $_[1]); + if ( ! $mapper ) + { + ${ $data{Error} } = $File::GlobMapper::Error ; + return undef ; + } + $data{Pairs} = $mapper->getFileMap(); + + return $obj; + } + + croak("$reportClass: input and output $inType are identical") + if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ; + + if ($inType eq 'fileglob') # && $outType ne 'fileglob' + { + my $glob = cleanFileGlobString($_[0]); + my @inputs = glob($glob); + + if (@inputs == 0) + { + # legal or die? + die "legal or die???" ; + } + elsif (@inputs == 1) + { + $obj->validateInputFilenames($inputs[0]) + or return undef; + $_[0] = $inputs[0] ; + $data{inType} = 'filename' ; + $data{oneInput} = 1; + } + else + { + $obj->validateInputFilenames(@inputs) + or return undef; + $_[0] = [ @inputs ] ; + $data{inType} = 'filenames' ; + } + } + elsif ($inType eq 'filename') + { + $obj->validateInputFilenames($_[0]) + or return undef; + } + elsif ($inType eq 'array') + { + $obj->validateInputArray($_[0]) + or return undef ; + } + + croak("$reportClass: output buffer is read-only") + if $outType eq 'buffer' && Compress::Zlib::_readonly_ref($_[1]); + + if ($outType eq 'filename' ) + { + croak "$reportClass: output filename is undef or null string" + if ! defined $_[1] || $_[1] eq '' ; + } + + return $obj ; +} + + +sub Validator::validateInputFilenames +{ + my $self = shift ; + + foreach my $filename (@_) + { + croak "$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; + } + + if (! -r $filename ) + { + ${ $self->{Error} } = "cannot open file '$filename': $!"; + return undef; + } + } + + return 1 ; +} + +sub Validator::validateInputArray +{ + my $self = shift ; + + foreach my $element ( @{ $_[0] } ) + { + my $inType = whatIsInput($element); + + if (! $inType) + { + ${ $self->{Error} } = "unknown input parameter" ; + return undef ; + } + } + + return 1 ; +} + +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') + { + ${ $self->{Error} } = "hash key not filename" ; + return undef ; + } + + my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ; + if (! $valid{$vtype}) + { + ${ $self->{Error} } = "hash value not ok" ; + return undef ; + } + } + + return $self ; +} + +1; diff --git a/ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm b/ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm new file mode 100644 index 0000000000..69befce53d --- /dev/null +++ b/ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm @@ -0,0 +1,75 @@ + +package Compress::Zlib::FileConstants ; + +use strict ; +use warnings; +use bytes; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT); + +$VERSION = '2.000_05'; + +@ISA = qw(Exporter); + +@EXPORT= qw( + + ZLIB_HEADER_SIZE + ZLIB_TRAILER_SIZE + + ZLIB_CMF_CM_OFFSET + ZLIB_CMF_CM_BITS + ZLIB_CMF_CM_DEFLATED + + ZLIB_CMF_CINFO_OFFSET + ZLIB_CMF_CINFO_BITS + + ZLIB_FLG_FCHECK_OFFSET + ZLIB_FLG_FCHECK_BITS + + ZLIB_FLG_FDICT_OFFSET + ZLIB_FLG_FDICT_BITS + + ZLIB_FLG_LEVEL_OFFSET + ZLIB_FLG_LEVEL_BITS + + ZLIB_FLG_LEVEL_FASTEST + ZLIB_FLG_LEVEL_FAST + ZLIB_FLG_LEVEL_DEFAULT + ZLIB_FLG_LEVEL_SLOWEST + + ZLIB_FDICT_SIZE + + ); + +# Constant names derived from RFC1950 + +use constant ZLIB_HEADER_SIZE => 2; +use constant ZLIB_TRAILER_SIZE => 4; + +use constant ZLIB_CMF_CM_OFFSET => 0; +use constant ZLIB_CMF_CM_BITS => 0xF ; # 0b1111 +use constant ZLIB_CMF_CM_DEFLATED => 8; + +use constant ZLIB_CMF_CINFO_OFFSET => 4; +use constant ZLIB_CMF_CINFO_BITS => 0xF ; # 0b1111; + +use constant ZLIB_FLG_FCHECK_OFFSET => 0; +use constant ZLIB_FLG_FCHECK_BITS => 0x1F ; # 0b11111; + +use constant ZLIB_FLG_FDICT_OFFSET => 5; +use constant ZLIB_FLG_FDICT_BITS => 0x1 ; # 0b1; + +use constant ZLIB_FLG_LEVEL_OFFSET => 6; +use constant ZLIB_FLG_LEVEL_BITS => 0x3 ; # 0b11; + +use constant ZLIB_FLG_LEVEL_FASTEST => 0; +use constant ZLIB_FLG_LEVEL_FAST => 1; +use constant ZLIB_FLG_LEVEL_DEFAULT => 2; +use constant ZLIB_FLG_LEVEL_SLOWEST => 3; + +use constant ZLIB_FDICT_SIZE => 4; + + +1; diff --git a/ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm b/ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm new file mode 100644 index 0000000000..d89ec6764e --- /dev/null +++ b/ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm @@ -0,0 +1,262 @@ + +package Compress::Zlib::ParseParameters ; + +use strict; +use warnings; +use Carp; + +require Exporter; +our ($VERSION, @ISA, @EXPORT); +$VERSION = '2.000_05'; +@ISA = qw(Exporter); + +use constant Parse_any => 0x01; +use constant Parse_unsigned => 0x02; +use constant Parse_signed => 0x04; +use constant Parse_boolean => 0x08; +use constant Parse_string => 0x10; +use constant Parse_custom => 0x12; + +use constant Parse_store_ref => 0x100 ; + +use constant OFF_PARSED => 0 ; +use constant OFF_TYPE => 1 ; +use constant OFF_DEFAULT => 2 ; +use constant OFF_FIXED => 3 ; + +push @EXPORT, qw( ParseParameters + Parse_any Parse_unsigned Parse_signed + Parse_boolean Parse_custom Parse_string + Parse_store_ref + ); + +sub ParseParameters +{ + my $level = shift || 0 ; + + my $sub = (caller($level + 1))[3] ; + local $Carp::CarpLevel = 1 ; + my $p = new Compress::Zlib::ParseParameters() ; + $p->parse(@_) + or croak "$sub: $p->{Error}" ; + + return $p; +} + +sub new +{ + my $class = shift ; + my $obj = { Error => '', + Got => {}, + } ; + + #return bless $obj, ref($class) || $class || __PACKAGE__ ; + return bless $obj ; +} + +sub setError +{ + my $self = shift ; + my $error = shift ; + my $retval = @_ ? shift : undef ; + + $self->{Error} = $error ; + return $retval; +} + +#sub getError +#{ +# my $self = shift ; +# return $self->{Error} ; +#} + +sub parse +{ + my $self = shift ; + + my $default = shift ; + + my (@Bad) ; + my @entered = () ; + + # Allow the options to be passed as a hash reference or + # as the complete hash. + if (@_ == 0) { + @entered = () ; + } + elsif (@_ == 1) { + my $href = $_[0] ; + return $self->setError("Expected even number of parameters, got 1") + if ! defined $href or ! ref $href or ref $href ne "HASH" ; + + foreach my $key (keys %$href) { + push @entered, $key ; + push @entered, \$href->{$key} ; + } + } + else { + my $count = @_; + return $self->setError("Expected even number of parameters, got $count") + if $count % 2 != 0 ; + + for my $i (0.. $count / 2 - 1) { + push @entered, $_[2* $i] ; + push @entered, \$_[2* $i+1] ; + } + } + + + my %got = () ; + while (my ($key, $v) = each %$default) + { + my ($type, $value) = @$v ; + my $x ; + $self->_checkType($key, \$value, $type, 0, \$x) + or return undef ; + $got{lc $key} = [0, $type, $value, $x] ; + } + + for my $i (0.. @entered / 2 - 1) { + my $key = $entered[2* $i] ; + my $value = $entered[2* $i+1] ; + + #print "Key [$key] Value [$value]" ; + #print defined $$value ? "[$$value]\n" : "[undef]\n"; + + $key =~ s/^-// ; + + if ($got{lc $key}) + { + my $type = $got{lc $key}[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] ; + } + else + { push (@Bad, $key) } + } + + if (@Bad) { + my ($bad) = join(", ", @Bad) ; + return $self->setError("unknown key value(s) @Bad") ; + } + + $self->{Got} = { %got } ; + + return 1; +} + +sub _checkType +{ + my $self = shift ; + + my $key = shift ; + my $value = shift ; + my $type = shift ; + my $validate = shift ; + my $output = shift; + + #local $Carp::CarpLevel = $level ; + #print "PARSE $type $key $value $validate $sub\n" ; + if ( $type & Parse_store_ref) + { + #$value = $$value + # if ref ${ $value } ; + + $$output = $value ; + return 1; + } + + $value = $$value ; + + if ($type & Parse_any) + { + $$output = $value ; + return 1; + } + elsif ($type & Parse_unsigned) + { + 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+$/; + + $$output = defined $value ? $value : 0 ; + return 1; + } + elsif ($type & Parse_signed) + { + 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+$/; + + $$output = defined $value ? $value : 0 ; + return 1 ; + } + elsif ($type & Parse_boolean) + { + $$output = defined $value ? $value != 0 : 0 ; + return 1; + } + elsif ($type & Parse_string) + { + $$output = defined $value ? $value : "" ; + return 1; + } + + $$output = $value ; + return 1; +} + + + +sub parsed +{ + my $self = shift ; + my $name = shift ; + + return $self->{Got}{lc $name}[OFF_PARSED] ; +} + +sub value +{ + my $self = shift ; + my $name = shift ; + + if (@_) + { + $self->{Got}{lc $name}[OFF_PARSED] = 1; + $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ; + $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ; + } + + return $self->{Got}{lc $name}[OFF_FIXED] ; +} + +sub valueOrDefault +{ + my $self = shift ; + my $name = shift ; + my $default = shift ; + + my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ; + + return $value if defined $value ; + return $default ; +} + +sub wantValue +{ + my $self = shift ; + my $name = shift ; + + return defined $self->{Got}{lc $name}[OFF_DEFAULT] ; + +} + +1; + diff --git a/ext/Compress/Zlib/lib/File/GlobMapper.pm b/ext/Compress/Zlib/lib/File/GlobMapper.pm new file mode 100644 index 0000000000..b8542264cb --- /dev/null +++ b/ext/Compress/Zlib/lib/File/GlobMapper.pm @@ -0,0 +1,697 @@ +package File::GlobMapper; + +use strict; +use warnings; +use Carp; + +our ($CSH_GLOB); + +BEGIN +{ + if ($] < 5.006) + { + require File::BSDGlob; import File::BSDGlob qw(:glob) ; + $CSH_GLOB = File::BSDGlob::GLOB_CSH() ; + *globber = \&File::BSDGlob::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; + } +} + +our ($Error); + +our ($VERSION, @EXPORT_OK); +$VERSION = '0.000_02'; +@EXPORT_OK = qw( globmap ); + + +our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount); +$noPreBS = '(?<!\\\)' ; # no preceeding backslash +$metachars = '.*?[](){}'; +$matchMetaRE = '[' . quotemeta($metachars) . ']'; + +%mapping = ( + '*' => '([^/]*)', + '?' => '([^/])', + '.' => '\.', + '[' => '([', + '(' => '(', + ')' => ')', + ); + +%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /; + +sub globmap ($$;) +{ + my $inputGlob = shift ; + my $outputGlob = shift ; + + my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_) + or croak "globmap: $Error" ; + return $obj->getFileMap(); +} + +sub new +{ + my $class = shift ; + my $inputGlob = shift ; + my $outputGlob = shift ; + # TODO -- flags needs to default to whatever File::Glob does + my $flags = shift || $CSH_GLOB ; + #my $flags = shift ; + + $inputGlob =~ s/^\s*\<\s*//; + $inputGlob =~ s/\s*\>\s*$//; + + $outputGlob =~ s/^\s*\<\s*//; + $outputGlob =~ s/\s*\>\s*$//; + + my %object = + ( InputGlob => $inputGlob, + OutputGlob => $outputGlob, + GlobFlags => $flags, + Braces => 0, + WildCount => 0, + Pairs => [], + Sigil => '#', + ); + + my $self = bless \%object, ref($class) || $class ; + + $self->_parseInputGlob() + or return undef ; + + $self->_parseOutputGlob() + or return undef ; + + my @inputFiles = globber($self->{InputGlob}, $flags) ; + + if (GLOB_ERROR) + { + $Error = $!; + return undef ; + } + + #if (whatever) + { + my $missing = grep { ! -e $_ } @inputFiles ; + + if ($missing) + { + $Error = "$missing input files do not exist"; + return undef ; + } + } + + $self->{InputFiles} = \@inputFiles ; + + $self->_getFiles() + or return undef ; + + return $self; +} + +sub _retError +{ + my $string = shift ; + $Error = "$string in input fileglob" ; + return undef ; +} + +sub _unmatched +{ + my $delimeter = shift ; + + _retError("Unmatched $delimeter"); + return undef ; +} + +sub _parseBit +{ + my $self = shift ; + + my $string = shift ; + + my $out = ''; + my $depth = 0 ; + + while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//) + { + $out .= quotemeta($1) ; + $out .= $mapping{$2} if defined $mapping{$2}; + + ++ $self->{WildCount} if $wildCount{$2} ; + + if ($2 eq ',') + { + return _unmatched "(" + if $depth ; + + $out .= '|'; + } + elsif ($2 eq '(') + { + ++ $depth ; + } + elsif ($2 eq ')') + { + return _unmatched ")" + if ! $depth ; + + -- $depth ; + } + elsif ($2 eq '[') + { + # TODO -- quotemeta & check no '/' + # TODO -- check for \] & other \ within the [] + $string =~ s#(.*?\])## + or return _unmatched "[" ; + $out .= "$1)" ; + } + elsif ($2 eq ']') + { + return _unmatched "]" ; + } + elsif ($2 eq '{' || $2 eq '}') + { + return _retError "Nested {} not allowed" ; + } + } + + $out .= quotemeta $string; + + return _unmatched "(" + if $depth ; + + return $out ; +} + +sub _parseInputGlob +{ + my $self = shift ; + + my $string = $self->{InputGlob} ; + my $inGlob = ''; + + # Multiple concatenated *'s don't make sense + #$string =~ s#\*\*+#*# ; + + # TODO -- Allow space to delimit patterns? + #my @strings = split /\s+/, $string ; + #for my $str (@strings) + my $out = ''; + my $depth = 0 ; + + while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//) + { + $out .= quotemeta($1) ; + $out .= $mapping{$2} if defined $mapping{$2}; + ++ $self->{WildCount} if $wildCount{$2} ; + + if ($2 eq '(') + { + ++ $depth ; + } + elsif ($2 eq ')') + { + return _unmatched ")" + if ! $depth ; + + -- $depth ; + } + elsif ($2 eq '[') + { + # TODO -- quotemeta & check no '/' or '(' or ')' + # TODO -- check for \] & other \ within the [] + $string =~ s#(.*?\])## + or return _unmatched "["; + $out .= "$1)" ; + } + elsif ($2 eq ']') + { + return _unmatched "]" ; + } + elsif ($2 eq '}') + { + return _unmatched "}" ; + } + elsif ($2 eq '{') + { + # TODO -- check no '/' within the {} + # TODO -- check for \} & other \ within the {} + + my $tmp ; + unless ( $string =~ s/(.*?)$noPreBS\}//) + { + return _unmatched "{"; + } + #$string =~ s#(.*?)\}##; + + #my $alt = join '|', + # map { quotemeta $_ } + # split "$noPreBS,", $1 ; + my $alt = $self->_parseBit($1); + defined $alt or return 0 ; + $out .= "($alt)" ; + + ++ $self->{Braces} ; + } + } + + return _unmatched "(" + if $depth ; + + $out .= quotemeta $string ; + + + $self->{InputGlob} =~ s/$noPreBS[\(\)]//g; + $self->{InputPattern} = $out ; + + #print "# INPUT '$self->{InputGlob}' => '$out'\n"; + + return 1 ; + +} + +sub _parseOutputGlob +{ + my $self = shift ; + + my $string = $self->{OutputGlob} ; + my $maxwild = $self->{WildCount}; + + if ($self->{GlobFlags} & GLOB_TILDE) + #if (1) + { + $string =~ s{ + ^ ~ # find a leading tilde + ( # save this in $1 + [^/] # a non-slash character + * # repeated 0 or more times (0 means me) + ) + }{ + $1 + ? (getpwnam($1))[7] + : ( $ENV{HOME} || $ENV{LOGDIR} ) + }ex; + + } + + # max #1 must be == to max no of '*' in input + while ( $string =~ m/#(\d)/g ) + { + croak "Max wild is #$maxwild, you tried #$1" + if $1 > $maxwild ; + } + + my $noPreBS = '(?<!\\\)' ; # no preceeding backslash + #warn "noPreBS = '$noPreBS'\n"; + + #$string =~ s/${noPreBS}\$(\d)/\${$1}/g; + $string =~ s/${noPreBS}#(\d)/\${$1}/g; + $string =~ s#${noPreBS}\*#\${inFile}#g; + $string = '"' . $string . '"'; + + #print "OUTPUT '$self->{OutputGlob}' => '$string'\n"; + $self->{OutputPattern} = $string ; + + return 1 ; +} + +sub _getFiles +{ + my $self = shift ; + + my %outInMapping = (); + my %inFiles = () ; + + foreach my $inFile (@{ $self->{InputFiles} }) + { + next if $inFiles{$inFile} ++ ; + + my $outFile = $inFile ; + + if ( $inFile =~ m/$self->{InputPattern}/ ) + { + no warnings 'uninitialized'; + eval "\$outFile = $self->{OutputPattern};" ; + + if (defined $outInMapping{$outFile}) + { + $Error = "multiple input files map to one output file"; + return undef ; + } + $outInMapping{$outFile} = $inFile; + push @{ $self->{Pairs} }, [$inFile, $outFile]; + } + } + + return 1 ; +} + +sub getFileMap +{ + my $self = shift ; + + return $self->{Pairs} ; +} + +sub getHash +{ + my $self = shift ; + + return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ; +} + +1; + +__END__ + +=head1 NAME + +File::GlobMapper - Extend File Glob to Allow Input and Output Files + +=head1 SYNOPSIS + + use File::GlobMapper qw( globmap ); + + my $aref = globmap $input => $output + or die $File::GlobMapper::Error ; + + my $gm = new File::GlobMapper $input => $output + or die $File::GlobMapper::Error ; + + +=head1 DESCRIPTION + +B<WARNING Alpha Release Alert!> + +=over 5 + +=item * This code is a work in progress. + +=item * There are known bugs. + +=item * The interface defined here is tentative. + +=item * There are portability issues. + +=item * Do not use in production code. + +=item * Consider yourself warned! + +=back + +This module needs Perl5.005 or better. + +This module takes the existing C<File::Glob> module as a starting point and +extends it to allow new filenames to be derived from the files matched by +C<File::Glob>. + +This can be useful when carrying out batch operations on multiple files that +have both an input filename and output filename and the output file can be +derived from the input filename. Examples of operations where this can be +useful include, file renaming, file copying and file compression. + + +=head2 Behind The Scenes + +To help explain what C<File::GlobMapper> does, consider what code you +would write if you wanted to rename all files in the current directory +that ended in C<.tar.gz> to C<.tgz>. So say these files are in the +current directoty + + alpha.tar.gz + beta.tar.gz + gamma.tar.gz + +and they need renamed to this + + alpha.tgz + beta.tgz + gamma.tgz + +Below is a possible implementation of a script to carry out the rename +(error cases have been omitted) + + foreach my $old ( glob "*.tar.gz" ) + { + my $new = $old; + $new =~ s#(.*)\.tar\.gz$#$1.tgz# ; + + rename $old => $new + or die "Cannot rename '$old' to '$new': $!\n; + } + +Notice that a file glob pattern C<*.tar.gz> was used to match the +C<.tar.gz> files, then a fairly similar regular expression was used in +the substitute to allow the new filename to be created. + +Given that the file glob is just a cut-down regular expression and that it +has already done a lot of the hard work in pattern matching the filenames, +wouldn't it be handy to be able to use the patterns in the fileglob to +drive the new filename? + +Well, that's I<exactly> what C<File::GlobMapper> does. + +Here is same snippet of code rewritten using C<globmap> + + for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' ) + { + my ($from, $to) = @$pair; + rename $from => $to + or die "Cannot rename '$old' to '$new': $!\n; + } + +So how does it work? + +Behind the scenes the C<globmap> function does a combination of a +file glob to match existing filenames followed by a substitute +to create the new filenames. + +Notice how both parameters to C<globmap> are strings that are delimired by <>. +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 +present. + +The first parameter to C<globmap>, C<*.tar.gz>, is an I<Input File Glob>. +Once the enclosing "< ... >" is removed, this is passed (more or +less) unchanged to C<File::Glob> to carry out a file match. + +Next the fileglob C<*.tar.gz> is transformed behind the scenes into a +full Perl regular expression, with the additional step of wrapping each +transformed wildcard metacharacter sequence in parenthesis. + +In this case the input fileglob C<*.tar.gz> will be transformed into +this Perl regular expression + + ([^/]*)\.tar\.gz + +Wrapping with parenthesis allows the wildcard parts of the Input File +Glob to be referenced by the second parameter to C<globmap>, C<#1.tgz>, +the I<Output File Glob>. This parameter operates just like the replacement +part of a substitute command. The difference is that the C<#1> syntax +is used to reference sub-patterns matched in the input fileglob, rather +than the C<$1> syntax that is used with perl regular expressions. In +this case C<#1> is used to refer to the text matched by the C<*> in the +Input File Glob. This makes it easier to use this module where the +parameters to C<globmap> are typed at the command line. + +The final step involves passing each filename matched by the C<*.tar.gz> +file glob through the derived Perl regular expression in turn and +expanding the output fileglob using it. + +The end result of all this is a list of pairs of filenames. By default +that is what is returned by C<globmap>. In this example the data structure +returned will look like this + + ( ['alpha.tar.gz' => 'alpha.tgz'], + ['beta.tar.gz' => 'beta.tgz' ], + ['gamma.tar.gz' => 'gamma.tgz'] + ) + + +Each pair is an array reference with two elements - namely the I<from> +filename, that C<File::Glob> has matched, and a I<to> filename that is +derived from the I<from> filename. + + + +=head2 Limitations + +C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to +solve all filename mapping operations. Under the hood C<File::Glob> (or for +older verions of Perl, C<File::BSDGlob>) is used to match the files, so you +will never have the flexibility of full Perl regular expression. + +=head2 Input File Glob + +The syntax for an Input FileGlob is identical to C<File::Glob>, except +for the following + +=over 5 + +=item 1. + +No nested {} + +=item 2. + +Whitespace does not delimit fileglobs. + +=item 3. + +The use of parenthesis can be used to capture parts of the input filename. + +=item 4. + +If an Input glob matches the same file more than once, only the first +will be used. + +=back + +The syntax + +=over 5 + +=item B<~> + +=item B<~user> + + +=item B<.> + +Matches a literal '.'. +Equivalent to the Perl regular expression + + \. + +=item B<*> + +Matches zero or more characters, except '/'. Equivalent to the Perl +regular expression + + [^/]* + +=item B<?> + +Matches zero or one character, except '/'. Equivalent to the Perl +regular expression + + [^/]? + +=item B<\> + +Backslash is used, as usual, to escape the next character. + +=item B<[]> + +Character class. + +=item B<{,}> + +Alternation + +=item B<()> + +Capturing parenthesis that work just like perl + +=back + +Any other character it taken literally. + +=head2 Output File Glob + +The Output File Glob is a normal string, with 2 glob-like features. + +The first is the '*' metacharacter. This will be replaced by the complete +filename matched by the input file glob. So + + *.c *.Z + +The second is + +Output FileGlobs take the + +=over 5 + +=item "*" + +The "*" chanacter will be replaced with the complete input filename. + +=item #1 + +Patterns of the form /#\d/ will be replaced with the + +=back + +=head2 Returned Data + + +=head1 EXAMPLES + +=head2 A Rename script + +Below is a simple "rename" script that uses C<globmap> to determine the +source and destination filenames. + + use File::GlobMapper qw(globmap) ; + use File::Copy; + + die "rename: Usage rename 'from' 'to'\n" + unless @ARGV == 2 ; + + my $fromGlob = shift @ARGV; + my $toGlob = shift @ARGV; + + my $pairs = globmap($fromGlob, $toGlob) + or die $File::GlobMapper::Error; + + for my $pair (@$pairs) + { + my ($from, $to) = @$pair; + move $from => $to ; + } + + + +Here is an example that renames all c files to cpp. + + $ rename '*.c' '#1.cpp' + +=head2 A few example globmaps + +Below are a few examles of globmaps + +To copy all your .c file to a backup directory + + '</my/home/*.c>' '</my/backup/#1.c>' + +If you want to compress all + + '</my/home/*.[ch]>' '<*.gz>' + +To uncompress + + '</my/home/*.[ch].gz>' '</my/home/#1.#2>' + +=head1 SEE ALSO + +L<File::Glob|File::Glob> + +=head1 AUTHOR + +The I<File::GlobMapper> module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005 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/Deflate.pm b/ext/Compress/Zlib/lib/IO/Compress/Deflate.pm new file mode 100644 index 0000000000..8e7e72438b --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Compress/Deflate.pm @@ -0,0 +1,852 @@ +package IO::Compress::Deflate ; + +use strict ; +use warnings; +require Exporter ; + +use IO::Compress::Gzip ; + + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError); + +$VERSION = '2.000_05'; +$DeflateError = ''; + +@ISA = qw(Exporter IO::BaseDeflate); +@EXPORT_OK = qw( $DeflateError deflate ) ; +%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, 'rfc1950', undef, \$DeflateError, @_); +} + +sub deflate +{ + return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1950', \$DeflateError, @_); +} + + +1; + +__END__ + +=head1 NAME + +IO::Compress::Deflate - Perl interface to write RFC 1950 files/buffers + +=head1 SYNOPSIS + + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + + my $status = deflate $input => $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + my $z = new IO::Compress::Deflate $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->newStream(); + $z->deflateParams(); + $z->close() ; + + $DeflateError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + syswrite $z, $string [, $length, $offset]; + flush $z, ; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + + + +B<WARNING -- This is a Beta release>. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1950. + + + + + +For reading RFC 1950 files/buffers, see the companion module +L<IO::Uncompress::Inflate|IO::Uncompress::Inflate>. + + +=head1 Functional Interface + +A top-level function, C<deflate>, is provided to carry out "one-shot" +compression between buffers and/or files. For finer control over the compression process, see the L</"OO Interface"> section. + + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + deflate $input => $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + deflate \%hash [,OPTS] + or die "deflate failed: $DeflateError\n"; + +The functional interface needs Perl5.005 or better. + + +=head2 deflate $input => $output [, OPTS] + +If the first parameter is not a hash reference C<deflate> expects +at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, the input data will be read from each +element of the array in turn. The action taken by C<deflate> with +each element of the array will depend on the type of data stored +in it. You can mix and match any of the types defined in this list, +excluding other array or hash references. +The complete array will be walked to ensure that it only +contains valid data types before any data is compressed. + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<deflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a filename. +This file will be opened for writing and the compressed data will be +written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will +be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + + +=item A Hash Reference + +If C<$output> is a hash reference, the compressed data will be written +to C<$output{$input}> as a scalar reference. + +When C<$output> is a hash reference, C<$input> must be either a filename or +list of filenames. Anything else is an error. + + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be pushed +onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<deflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 deflate \%hash [, OPTS] + +If the first parameter is a hash reference, C<\%hash>, this will be used to +define both the source of uncompressed data and to control where the +compressed data is output. Each key/value pair in the hash defines a +mapping between an input filename, stored in the key, and an output +file/buffer, stored in the value. Although the input can only be a filename, +there is more flexibility to control the destination of the compressed +data. This is determined by the type of the value. Valid types are + +=over 5 + +=item undef + +If the value is C<undef> the compressed data will be written to the +value as a scalar reference. + +=item A filename + +If the value is a simple scalar, it is assumed to be a filename. This file will +be opened for writing and the compressed data will be written to it. + +=item A filehandle + +If the value is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If the value is a scalar reference, the compressed data will be stored +in the buffer that is referenced by the scalar. + + +=item A Hash Reference + +If the value is a hash reference, the compressed data will be written +to C<$hash{$input}> as a scalar reference. + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be pushed +onto the array. + +=back + +Any other type is a error. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the compressed input files/buffers will all be stored in +C<$output> as a single compressed stream. + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<deflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item AutoClose =E<gt> 0|1 + +This option applies to any input or output data streams to C<deflate> +that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<deflate> has +completed. + +This parameter defaults to 0. + + + +=item -Append =E<gt> 0|1 + +TODO + + +=back + + + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.1950>. + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + my $input = "file1.txt"; + deflate $input => "$input.1950" + or die "deflate failed: $DeflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + deflate $input => \$buffer + or die "deflate failed: $DeflateError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + deflate '</my/home/*.txt>' => '<*.1950>' + or die "deflate failed: $DeflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.1950" ; + deflate $input => $output + or die "Error compressing '$input': $DeflateError\n"; + } + + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::Deflate> is shown below + + my $z = new IO::Compress::Deflate $output [,OPTS] + or die "IO::Compress::Deflate failed: $DeflateError\n"; + +It returns an C<IO::Compress::Deflate> object on success and undef on failure. +The variable C<$DeflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Deflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::Deflate>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item -AutoClose =E<gt> 0|1 + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being closed +once either the C<close> method is called or the C<IO::Compress::Deflate> object is +destroyed. + +This parameter defaults to 0. + +=item -Append =E<gt> 0|1 + +Opens C<$output> in append mode. + +The behaviour of this option is dependant on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data will be +append to the end if C<$output>. Otherwise C<$output> will be cleared before +any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be opened +in append mode. Otherwise the contents of the file, if any, will be truncated +before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the end +of the file via a call to C<seek> before any compressed data is written to it. +Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item -Merge =E<gt> 0|1 + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + + + +It is a fatal error to attempt to use this option when C<$output> is not an RFC +1950 data stream. + + + +There are a number of other limitations with the C<Merge> option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A fatal +error will be thrown if C<Merge> is used with an older version of zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + + +This parameter defaults to 0. + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::Deflate> by default. + + use IO::Compress::Deflate qw(:strategy); + use IO::Compress::Deflate qw(:constants); + use IO::Compress::Deflate qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + + + + + +=item -Strict =E<gt> 0|1 + + + +This is a placeholder option. + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behavior as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + + syswrite $z, $data + syswrite $z, $data, $length + syswrite $z, $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + $z->flush($flush_type); + flush $z ; + flush $z $flush_type; + +Flushes any pending compressed data to the output file/buffer. + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + +Returns true on success. + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the C<close> method has been called. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file, this method will return +the underlying filehandle. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Flushes any pending compressed data and then closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Deflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::Deflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 newStream + +Usage is + + $z->newStream + +TODO + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + +=head1 Importing + +A number of symbolic constants are required by some methods in +C<IO::Compress::Deflate>. None are imported by default. + +=over 5 + +=item :all + +Imports C<deflate>, C<$DeflateError> and all symbolic +constants that can be used by C<IO::Compress::Deflate>. Same as doing this + + use IO::Compress::Deflate qw(deflate $DeflateError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + use IO::Compress::Deflate qw(:flush :level :strategy) ; + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +=back + +For + +=head1 EXAMPLES + +TODO + + + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::AnyInflate> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for the gzip program is F<http://www.gzip.org>. + +=head1 AUTHOR + +The I<IO::Compress::Deflate> module was written by Paul Marquess, +F<pmqs@cpan.org>. The latest copy of the module can be +found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>. + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005 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 new file mode 100644 index 0000000000..ce4255ffac --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Compress/Gzip.pm @@ -0,0 +1,2546 @@ + +package IO::Compress::Gzip ; + +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 Compress::Zlib 2 ; +use Compress::Zlib::Common; +use Compress::Zlib::FileConstants; +use Compress::Zlib::ParseParameters; +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 +{ + if (defined &utf8::downgrade ) + { *noUTF8 = \&utf8::downgrade } + 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'); + + 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 mkGzipHeader +{ + my $param = shift ; + + # stort-circuit if a minimal header is requested. + return GZIP_MINIMUM_HEADER if $param->value('Minimal') ; + + # METHOD + my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ; + + # FLAGS + my $flags = GZIP_FLG_DEFAULT ; + $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ; + $flags |= GZIP_FLG_FHCRC if $param->value('HeaderCRC') ; + $flags |= GZIP_FLG_FEXTRA if $param->wantValue('ExtraField') ; + $flags |= GZIP_FLG_FNAME if $param->wantValue('Name') ; + $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ; + + # MTIME + my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ; + + # EXTRA FLAGS + my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT); + + # OS CODE + my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ; + + + my $out = pack("C4 V C C", + GZIP_ID1, # ID1 + GZIP_ID2, # ID2 + $method, # Compression Method + $flags, # Flags + $time, # Modification Time + $extra_flags, # Extra Flags + $os_code, # Operating System Code + ) ; + + # EXTRA + if ($flags & GZIP_FLG_FEXTRA) { + my $extra = $param->value('ExtraField') ; + $out .= pack("v", length $extra) . $extra ; + } + + # NAME + if ($flags & GZIP_FLG_FNAME) { + my $name .= $param->value('Name') ; + $name =~ s/\x00.*$//; + $out .= $name ; + # Terminate the filename with NULL unless it already is + $out .= GZIP_NULL_BYTE + if !length $name or + substr($name, 1, -1) ne GZIP_NULL_BYTE ; + } + + # COMMENT + if ($flags & GZIP_FLG_FCOMMENT) { + my $comment .= $param->value('Comment') ; + $comment =~ s/\x00.*$//; + $out .= $comment ; + # Terminate the comment with NULL unless it already is + $out .= GZIP_NULL_BYTE + if ! length $comment or + substr($comment, 1, -1) ne GZIP_NULL_BYTE; + } + + # HEADER CRC + $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ; + + noUTF8($out); + + return $out ; +} + +sub ExtraFieldError +{ + return "Error with ExtraField Parameter: $_[0]" ; +} + +sub validateExtraFieldPair +{ + 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 ; +} + +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 parseExtraField +{ + 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, + # ... + # } + + + 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], + + # zlib behaviour + #'Method' => [Parse_unsigned, Z_DEFLATED], + 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION], + 'Strategy' => [Parse_signed, Z_DEFAULT_STRATEGY], + + # Gzip header fields + 'Minimal' => [Parse_boolean, 0], + 'Comment' => [Parse_any, undef], + 'Name' => [Parse_any, undef], + 'Time' => [Parse_any, undef], + 'TextFlag' => [Parse_boolean, 0], + 'HeaderCRC' => [Parse_boolean, 0], + 'OS_Code' => [Parse_unsigned, $Compress::Zlib::gzip_os_code], + 'ExtraField'=> [Parse_string, undef], + 'ExtraFlags'=> [Parse_any, undef], + } + : + { + 'AutoClose' => [Parse_boolean, 0], + #'Encoding' => [Parse_any, undef], + 'CRC32' => [Parse_boolean, 0], + 'ADLER32' => [Parse_boolean, 0], + 'Strict' => [Parse_boolean, 1], + 'Append' => [Parse_boolean, 0], + 'Merge' => [Parse_boolean, 0], + + # zlib behaviour + #'Method' => [Parse_unsigned, Z_DEFLATED], + 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION], + 'Strategy' => [Parse_signed, Z_DEFAULT_STRATEGY], + }, + @_) or croak "${class}: $got->{Error}" ; + + return $got ; +} + +sub new +{ + my $class = shift ; + my $type = shift ; + my $got = shift; + my $error_ref = shift ; + + croak("$class: Missing Output parameter") + if ! @_ && ! $got ; + + my $outValue = shift ; + my $oneShot = 1 ; + + if (! $got) + { + $oneShot = 0 ; + $got = checkParams($class, $type, @_) + or return undef ; + } + + my $rfc1952 = ($type eq 'rfc1952'); + my $rfc1950 = ($type eq 'rfc1950'); + my $rfc1951 = ($type eq 'rfc1951'); + + my $obj = bless Symbol::gensym(), ref($class) || $class; + tie *$obj, $obj if $] >= 5.005; + + *$obj->{Closed} = 1 ; + $$error_ref = '' ; + *$obj->{Error} = $error_ref ; + + my $lax = ! $got->value('Strict') ; + + my $outType = whatIsOutput($outValue); + + ckOutputParam($class, $outValue, $error_ref) + or return undef ; + + if ($outType eq 'buffer') { + *$obj->{Buffer} = $outValue; + } + else { + my $buff = "" ; + *$obj->{Buffer} = \$buff ; + } + + # Merge implies Append + my $merge = $got->value('Merge') ; + my $appendOutput = $got->value('Append') || $merge ; + + if ($merge) + { + # Switch off Merge mode if output file/buffer is empty/doesn't exist + if (($outType eq 'buffer' && length $$outValue == 0 ) || + ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) ) + { $merge = 0 } + } + + # If output is a file, check that it is writable + if ($outType eq 'filename' && -e $outValue && ! -w _) + { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) } + + elsif ($outType eq 'handle' && ! -w $outValue) + { return $obj->saveErrorString(undef, "Output filehandle is not writable" ) } + + +# TODO - encoding +# if ($got->parsed('Encoding')) { +# croak("$class: Encode module needed to use -Encoding") +# if ! $got_encode; +# +# my $want_encoding = $got->value('Encoding'); +# my $encoding = find_encoding($want_encoding); +# +# croak("$class: Encoding '$want_encoding' is not available") +# if ! $encoding; +# +# *$obj->{Encoding} = $encoding; +# } + + if ($rfc1952 && ! $merge) { + + if (! $got->parsed('Time') ) { + # Modification time defaults to now. + $got->value('Time' => time) ; + } + + # Check that the Name & Comment don't have embedded NULLs + # Also check that they only contain ISO 8859-1 chars. + if ($got->parsed('Name') && defined $got->value('Name')) { + my $name = $got->value('Name'); + + return $obj->saveErrorString(undef, "Null Character found in Name", + Z_DATA_ERROR) + if ! $lax && $name =~ /\x00/ ; + + return $obj->saveErrorString(undef, "Non ISO 8859-1 Character found in Name", + Z_DATA_ERROR) + if ! $lax && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; + } + + if ($got->parsed('Comment') && defined $got->value('Comment')) { + my $comment = $got->value('Comment'); + + return $obj->saveErrorString(undef, "Null Character found in Comment", + Z_DATA_ERROR) + if ! $lax && $comment =~ /\x00/ ; + + return $obj->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment", + Z_DATA_ERROR) + if ! $lax && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o; + } + + if ($got->parsed('OS_Code') ) { + my $value = $got->value('OS_Code'); + + return $obj->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'") + if $value < 0 || $value > 255 ; + + } + + # gzip only supports Deflate at present + $got->value('Method' => Z_DEFLATED) ; + + if ( ! $got->parsed('ExtraFlags')) { + $got->value('ExtraFlags' => 2) + if $got->value('Level') == Z_BEST_SPEED ; + $got->value('ExtraFlags' => 4) + if $got->value('Level') == Z_BEST_COMPRESSION ; + } + + if ($got->parsed('ExtraField')) { + + my $bad = $obj->parseExtraField($got, $lax) ; + return $obj->saveErrorString(undef, $bad, Z_DATA_ERROR) + if $bad ; + + my $len = length $got->value('ExtraField') ; + return $obj->saveErrorString(undef, ExtraFieldError("Too Large"), + Z_DATA_ERROR) + if $len > GZIP_FEXTRA_MAX_SIZE; + } + } + + $obj->saveStatus(Z_OK) ; + + my $end_offset = 0; + my $status ; + if (! $merge) + { + (*$obj->{Deflate}, $status) = new Compress::Zlib::Deflate + -AppendOutput => 1, + -CRC32 => $rfc1952 || $got->value('CRC32'), + -ADLER32 => $rfc1950 || $got->value('ADLER32'), + -Level => $got->value('Level'), + -Strategy => $got->value('Strategy'), + -WindowBits => - MAX_WBITS; + return $obj->saveErrorString(undef, "Cannot create Deflate object: $status" ) + if $obj->saveStatus($status) != Z_OK ; + + *$obj->{BytesWritten} = 0 ; + *$obj->{ISize} = 0 ; + + *$obj->{Header} = mkDeflateHeader($got) + if $rfc1950 ; + *$obj->{Header} = '' + if $rfc1951 ; + *$obj->{Header} = mkGzipHeader($got) + if $rfc1952 ; + + if ( $outType eq 'buffer') { + ${ *$obj->{Buffer} } = '' + unless $appendOutput ; + ${ *$obj->{Buffer} } .= *$obj->{Header}; + } + else { + if ($outType eq 'handle') { + $outValue->flush() ; + *$obj->{FH} = $outValue ; + *$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; + + return $obj ; +} + +sub _def +{ + my $class = shift ; + my $type = shift ; + my $error_ref = shift ; + + my $name = (caller(1))[3] ; + + croak "$name: expected at least 1 parameters\n" + unless @_ >= 1 ; + + my $input = shift ; + my $haveOut = @_ ; + my $output = shift ; + + my $x = new Validator($class, $type, $error_ref, $name, $input, $output) + or return undef ; + + push @_, $output if $haveOut && $x->{Hash}; + + my $got = checkParams($name, $type, @_) + or return undef ; + + $x->{Got} = $got ; + $x->{ParsedTime} = $got->parsed('Time') ; + $x->{ParsedName} = $got->parsed('Name') ; + + if ($x->{Hash}) + { + while (my($k, $v) = each %$input) + { + $v = \$input->{$k} + unless defined $v ; + + _singleTarget($x, 1, $k, $v, @_) + or return undef ; + } + + return keys %$input ; + } + + if ($x->{GlobMap}) + { + $x->{oneInput} = 1 ; + foreach my $pair (@{ $x->{Pairs} }) + { + my ($from, $to) = @$pair ; + _singleTarget($x, 1, $from, $to, @_) + or return undef ; + } + + return scalar @{ $x->{Pairs} } ; + } + + if (! $x->{oneOutput} ) + { + my $inFile = ($x->{inType} eq 'filenames' + || $x->{inType} eq 'filename'); + + $x->{inType} = $inFile ? 'filename' : 'buffer'; + + foreach my $in ($x->{oneInput} ? $input : @$input) + { + my $out ; + $x->{oneInput} = 1 ; + + _singleTarget($x, $inFile, $in, \$out, @_) + or return undef ; + + if ($x->{outType} eq 'array') + { push @$output, \$out } + else + { $output->{$in} = \$out } + } + + return 1 ; + } + + # finally the 1 to 1 and n to 1 + return _singleTarget($x, 1, $input, $output, @_); + + croak "should not be here" ; +} + +sub _singleTarget +{ + my $x = shift ; + my $inputIsFilename = shift; + my $input = shift; + + + # For gzip, if input is simple filename, populate Name & Time in + # gzip header from filename by default. + if ($x->{Type} eq 'rfc1952' and isaFilename($input) and $inputIsFilename) + { + my $defaultTime = (stat($input))[8] ; + + $x->{Got}->value('Name' => $input) + if ! $x->{ParsedName}; + + $x->{Got}->value('Time' => $defaultTime) + if ! $x->{ParsedTime}; + } + + my $gzip = new($x->{Class}, $x->{Type}, $x->{Got}, $x->{Error}, @_) + or return undef ; + + + if ($x->{oneInput}) + { + defined $gzip->_wr2($input, $inputIsFilename) + or return undef ; + } + else + { + my $afterFirst = 0 ; + my $inputIsFilename = ($x->{inType} ne 'array'); + + for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) + { + if ( $afterFirst ++ ) + { + defined addInterStream($gzip, $x, $element, $inputIsFilename) + or return undef ; + } + + defined $gzip->_wr2($element, $inputIsFilename) + or return undef ; + } + } + + return $gzip->close() ; +} + +sub _wr2 +{ + my $self = shift ; + + my $source = shift ; + my $inputIsFilename = shift; + + my $input = $source ; + if (! $inputIsFilename) + { + $input = \$source + if ! ref $source; + } + + if ( ref $input && ref $input eq 'SCALAR' ) + { + return $self->syswrite($input, @_) ; + } + + if ( ! ref $input || isaFilehandle($input)) + { + my $isFilehandle = isaFilehandle($input) ; + + my $fh = $input ; + + if ( ! $isFilehandle ) + { + $fh = new IO::File "<$input" + or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ; + } + setBinModeInput($fh) ; + + 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 ; +} + +sub TIEHANDLE +{ + return $_[0] if ref($_[0]); + die "OOPS\n" ; +} + +sub UNTIE +{ + my $self = shift ; +} + +sub DESTROY +{ + my $self = shift ; + $self->close() ; + + # TODO - memory leak with 5.8.0 - this isn't called until + # global destruction + # + %{ *$self } = () ; + undef $self ; +} + + +#sub validateInput +#{ +# my $class = shift ; +# +# #local $Carp::CarpLevel = 1; +# +# if ( ! ref $_[0] || +# ref $_[0] eq 'SCALAR' || +# #ref $_[0] eq 'CODE' || +# isaFilehandle($_[0]) ) +# { +# my $inType = whatIs($_[0]); +# my $outType = whatIs($_[1]); +# +# if ($inType eq 'filename' ) +# { +# croak "$class: input filename is undef or null string" +# if ! defined $_[0] || $_[0] eq '' ; +# +# if ($_[0] ne '-' && ! -e $_[0] ) +# { +# ${$_[2]} = "input file '$_[0]' does not exist"; +# $_[3] = $!; +# return undef; +# } +# +# if (! -r $_[0] ) +# { +# ${$_[2]} = "cannot open file '$_[0]': $!"; +# $_[3] = $!; +# return undef; +# } +# } +# elsif ($inType eq 'fileglob' ) +# { +# # whatever... +# } +# +# croak("$class: input and output $inType are identical") +# if defined $outType && $inType eq $outType && $_[0] eq $_[1] ; +# +# return 1 ; +# } +# +# croak "$class: input parameter not a filename, filehandle, array ref or scalar ref" +# unless ref $_[0] eq 'ARRAY' ; +# +# my $array = shift @_ ; +# foreach my $element ( @{ $array } ) +# { +# return undef +# unless validateInput($class, $element, @_); +# } +# +# return 1 ; +#} + + +#sub write +#{ +# my $self = shift ; +# +# if ( isaFilehandle $_[0] ) +# { +# return $self->_wr(@_); +# } +# +# if ( ref $_[0]) +# { +# if ( ref $_[0] eq 'SCALAR' ) +# { return $self->syswrite(@_) } +# +# if ( ref $_[0] eq 'ARRAY' ) +# { +# my ($str, $num); +# validateInput(*$self->{ClassName} . "::write", $_[0], *$self->{Output}, \$str, $num) +# or return $self->saveErrorString(undef, $str, $num); +# +# return $self->_wr(@_); +# } +# +# croak *$self->{ClassName} . "::write: input parameter not a filename, filehandle, array ref or scalar ref"; +# } +# +# # Not a reference or a filehandle +# return $self->syswrite(@_) ; +#} +# +#sub _wr +#{ +# my $self = shift ; +# +# if ( ref $_[0] && ref $_[0] eq 'SCALAR' ) +# { +# return $self->syswrite(@_) ; +# } +# +# if ( ! ref $_[0] || isaFilehandle($_[0])) +# { +# my $item = shift @_ ; +# my $isFilehandle = isaFilehandle($item) ; +# +# my $fh = $item ; +# +# if ( ! $isFilehandle ) +# { +# $fh = new IO::File "<$item" +# or return $self->saveErrorString(undef, "cannot open file '$item': $!", $!) ; +# } +# +# my $status ; +# my $buff ; +# my $count = 0 ; +# while (($status = read($fh, $buff, 4096)) > 0) { +# $count += length $buff; +# defined $self->syswrite($buff, @_) +# or return undef ; +# } +# +# return $self->saveErrorString(undef, $!, $!) +# if $status < 0 ; +# +# +# if ( !$isFilehandle || *$self->{AutoClose} ) +# { +# $fh->close() +# or return undef ; +# } +# +# return $count ; +# } +# +# #if ref $_[0] eq 'CODE' ; +# +# # then must be ARRAY ref +# my $count = 0 ; +# my $array = shift @_ ; +# foreach my $element ( @{ $array } ) +# { +# my $got = $self->_wr($element, @_) ; +# +# return undef +# unless defined $got ; +# +# $count += $got ; +# } +# +# return $count ; +#} + + +sub syswrite +{ + my $self = shift ; + + my $buffer ; + if (ref $_[0] ) { + croak *$self->{ClassName} . "::write: not a scalar reference" + unless ref $_[0] eq 'SCALAR' ; + $buffer = $_[0] ; + } + else { + $buffer = \$_[0] ; + } + + if (@_ > 1) { + my $slen = defined $$buffer ? length($$buffer) : 0; + my $len = $slen; + my $offset = 0; + $len = $_[1] if $_[1] < $len; + + if (@_ > 2) { + $offset = $_[2] || 0; + croak *$self->{ClassName} . "::write: offset outside string" if $offset > $slen; + if ($offset < 0) { + $offset += $slen; + croak *$self->{ClassName} . "::write: offset outside string" if $offset < 0; + } + my $rem = $slen - $offset; + $len = $rem if $rem < $len; + } + + $buffer = \substr($$buffer, $offset, $len) ; + } + + my $buffer_length = defined $$buffer ? length($$buffer) : 0 ; + *$self->{BytesWritten} += $buffer_length ; + my $rest = GZIP_ISIZE_MAX - *$self->{ISize} ; + if ($buffer_length > $rest) { + *$self->{ISize} = $buffer_length - $rest - 1; + } + else { + *$self->{ISize} += $buffer_length ; + } + +# if (*$self->{Encoding}) { +# $$buffer = *$self->{Encoding}->encode($$buffer); +# } + + #my $length = length $$buffer; + my $status = *$self->{Deflate}->deflate($buffer, *$self->{Buffer}) ; + + return $self->saveErrorString(undef,"Deflate Error: $status") + if $self->saveStatus($status) != Z_OK ; + + if ( defined *$self->{FH} and length ${ *$self->{Buffer} }) { + defined *$self->{FH}->write( ${ *$self->{Buffer} }, length ${ *$self->{Buffer} } ) + or return $self->saveErrorString(undef, $!, $!); + ${ *$self->{Buffer} } = '' ; + } + + return $buffer_length; +} + +sub print +{ + my $self = shift; + + #if (ref $self) { + # $self = *$self{GLOB} ; + #} + + if (defined $\) { + if (defined $,) { + defined $self->syswrite(join($,, @_) . $\); + } else { + defined $self->syswrite(join("", @_) . $\); + } + } else { + if (defined $,) { + defined $self->syswrite(join($,, @_)); + } else { + defined $self->syswrite(join("", @_)); + } + } +} + +sub printf +{ + my $self = shift; + my $fmt = shift; + defined $self->syswrite(sprintf($fmt, @_)); +} + + + +sub flush +{ + my $self = shift ; + my $opt = shift || Z_FINISH ; + my $status = *$self->{Deflate}->flush(*$self->{Buffer}, $opt) ; + return $self->saveErrorString(0,"Deflate Error: $status") + if $self->saveStatus($status) != Z_OK ; + + if ( defined *$self->{FH} ) { + *$self->{FH}->clearerr(); + defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} }) + or return $self->saveErrorString(0, $!, $!); + ${ *$self->{Buffer} } = '' ; + } + + return 1; +} + +sub newStream +{ + my $self = shift ; + + $self->_writeTrailer(GZIP_MINIMUM_HEADER) + or return 0 ; + + my $status = *$self->{Deflate}->deflateReset() ; + return $self->saveErrorString(0,"Deflate Error: $status") + if $self->saveStatus($status) != Z_OK ; + + *$self->{BytesWritten} = 0 ; + *$self->{ISize} = 0 ; + + return 1 ; +} + +sub _writeTrailer +{ + my $self = shift ; + my $nextHeader = shift || '' ; + + my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ; + return $self->saveErrorString(0,"Deflate Error: $status") + if $self->saveStatus($status) != Z_OK ; + + if (*$self->{OutputGzip}) { + ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(), + *$self->{ISize} ); + ${ *$self->{Buffer} } .= $nextHeader ; + } + + if (*$self->{OutputDeflate}) { + ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() ); + ${ *$self->{Buffer} } .= *$self->{Header} ; + } + + return 1 if ! defined *$self->{FH} ; + + defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} }) + or return $self->saveErrorString(0, $!, $!); + + ${ *$self->{Buffer} } = '' ; + + return 1; +} + +sub close +{ + my $self = shift ; + + return 1 if *$self->{Closed} || ! *$self->{Deflate} ; + *$self->{Closed} = 1 ; + + untie *$self + if $] >= 5.008 ; + + if (0) { + $self->_writeTrailer() + or return 0 ; + } + else { + + + my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ; + return $self->saveErrorString(0,"Deflate Error: $status") + if $self->saveStatus($status) != Z_OK ; + + if (*$self->{OutputGzip}) { + ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(), + *$self->{ISize} ); + } + + if (*$self->{OutputDeflate}) { + ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() ); + } + + + return 1 if ! defined *$self->{FH} ; + + defined *$self->{FH}->write(${ *$self->{Buffer} }, length( ${ *$self->{Buffer} } )) + or return $self->saveErrorString(0, $!, $!); + + ${ *$self->{Buffer} } = '' ; + } + + if (defined *$self->{FH}) { + #if (! *$self->{Handle} || *$self->{AutoClose}) { + if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { + $! = 0 ; + *$self->{FH}->close() + or return $self->saveErrorString(0, $!, $!); + } + delete *$self->{FH} ; + # This delete can set $! in older Perls, so reset the errno + $! = 0 ; + } + + return 1; +} + +sub deflateParams +{ + my $self = shift ; + my $level = shift ; + my $strategy = shift ; + + my $status = *$self->{Deflate}->deflateParams(-Level => $level, + -Strategy => $strategy) ; + return $self->saveErrorString(0,"deflateParams Error: $status") + if $self->saveStatus($status) != Z_OK ; + + return 1; +} + + +#sub total_in +#sub total_out +#sub msg +# +#sub crc +#{ +# my $self = shift ; +# return *$self->{Deflate}->crc32() ; +#} +# +#sub msg +#{ +# my $self = shift ; +# return *$self->{Deflate}->msg() ; +#} +# +#sub dict_adler +#{ +# my $self = shift ; +# return *$self->{Deflate}->dict_adler() ; +#} +# +#sub get_Level +#{ +# my $self = shift ; +# return *$self->{Deflate}->get_Level() ; +#} +# +#sub get_Strategy +#{ +# my $self = shift ; +# return *$self->{Deflate}->get_Strategy() ; +#} + + +sub tell +{ + my $self = shift ; + + #return *$self->{Deflate}->total_in(); + return *$self->{BytesWritten} ; +} + +sub eof +{ + my $self = shift ; + + return *$self->{Closed} ; +} + + +sub seek +{ + my $self = shift ; + my $position = shift; + my $whence = shift ; + + my $here = $self->tell() ; + my $target = 0 ; + + #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + use IO::Handle ; + + if ($whence == IO::Handle::SEEK_SET) { + $target = $position ; + } + elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) { + $target = $here + $position ; + } + else { + croak *$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter"; + } + + # short circuit if seeking to current offset + return 1 if $target == $here ; + + # Outlaw any attempt to seek backwards + croak *$self->{ClassName} . "::seek: cannot seek backwards" + if $target < $here ; + + # Walk the file to the new offset + my $offset = $target - $here ; + + my $buffer ; + defined $self->syswrite("\x00" x $offset) + or return 0; + + return 1 ; +} + +sub binmode +{ + 1; +# my $self = shift ; +# return defined *$self->{FH} +# ? binmode *$self->{FH} +# : 1 ; +} + +sub fileno +{ + my $self = shift ; + return defined *$self->{FH} + ? *$self->{FH}->fileno() + : undef ; +} + +sub _notAvailable +{ + my $name = shift ; + return sub { croak "$name Not Available: File opened only for output" ; } ; +} + +*read = _notAvailable('read'); +*READ = _notAvailable('read'); +*readline = _notAvailable('readline'); +*READLINE = _notAvailable('readline'); +*getc = _notAvailable('getc'); +*GETC = _notAvailable('getc'); + +*FILENO = \&fileno; +*PRINT = \&print; +*PRINTF = \&printf; +*WRITE = \&syswrite; +*write = \&syswrite; +*SEEK = \&seek; +*TELL = \&tell; +*EOF = \&eof; +*CLOSE = \&close; +*BINMODE = \&binmode; + +#*sysread = \&_notAvailable; +#*syswrite = \&_write; + +1; + +__END__ + +=head1 NAME + +IO::Compress::Gzip - Perl interface to write RFC 1952 files/buffers + +=head1 SYNOPSIS + + use IO::Compress::Gzip qw(gzip $GzipError) ; + + + my $status = gzip $input => $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + my $z = new IO::Compress::Gzip $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->newStream(); + $z->deflateParams(); + $z->close() ; + + $GzipError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + syswrite $z, $string [, $length, $offset]; + flush $z, ; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + + + +B<WARNING -- This is a Beta release>. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1952. + + +All the gzip headers defined in RFC 1952 can be created using +this module. + + + + +For reading RFC 1952 files/buffers, see the companion module +L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>. + + +=head1 Functional Interface + +A top-level function, C<gzip>, is provided to carry out "one-shot" +compression between buffers and/or files. For finer control over the compression process, see the L</"OO Interface"> section. + + use IO::Compress::Gzip qw(gzip $GzipError) ; + + gzip $input => $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + gzip \%hash [,OPTS] + or die "gzip failed: $GzipError\n"; + +The functional interface needs Perl5.005 or better. + + +=head2 gzip $input => $output [, OPTS] + +If the first parameter is not a hash reference C<gzip> expects +at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, the input data will be read from each +element of the array in turn. The action taken by C<gzip> with +each element of the array will depend on the type of data stored +in it. You can mix and match any of the types defined in this list, +excluding other array or hash references. +The complete array will be walked to ensure that it only +contains valid data types before any data is compressed. + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<gzip> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +In addition, if C<$input> is a simple filename, the default values for +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 +executable. +If you do not want to use these defaults they can be overridden by +explicitly setting the C<Name> and C<Time> options. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a filename. +This file will be opened for writing and the compressed data will be +written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will +be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + + +=item A Hash Reference + +If C<$output> is a hash reference, the compressed data will be written +to C<$output{$input}> as a scalar reference. + +When C<$output> is a hash reference, C<$input> must be either a filename or +list of filenames. Anything else is an error. + + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be pushed +onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<gzip> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 gzip \%hash [, OPTS] + +If the first parameter is a hash reference, C<\%hash>, this will be used to +define both the source of uncompressed data and to control where the +compressed data is output. Each key/value pair in the hash defines a +mapping between an input filename, stored in the key, and an output +file/buffer, stored in the value. Although the input can only be a filename, +there is more flexibility to control the destination of the compressed +data. This is determined by the type of the value. Valid types are + +=over 5 + +=item undef + +If the value is C<undef> the compressed data will be written to the +value as a scalar reference. + +=item A filename + +If the value is a simple scalar, it is assumed to be a filename. This file will +be opened for writing and the compressed data will be written to it. + +=item A filehandle + +If the value is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If the value is a scalar reference, the compressed data will be stored +in the buffer that is referenced by the scalar. + + +=item A Hash Reference + +If the value is a hash reference, the compressed data will be written +to C<$hash{$input}> as a scalar reference. + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be pushed +onto the array. + +=back + +Any other type is a error. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the compressed input files/buffers will all be stored in +C<$output> as a single compressed stream. + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<gzip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item AutoClose =E<gt> 0|1 + +This option applies to any input or output data streams to C<gzip> +that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<gzip> has +completed. + +This parameter defaults to 0. + + + +=item -Append =E<gt> 0|1 + +TODO + + +=back + + + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.gz>. + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + + my $input = "file1.txt"; + gzip $input => "$input.gz" + or die "gzip failed: $GzipError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + gzip $input => \$buffer + or die "gzip failed: $GzipError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + + gzip '</my/home/*.txt>' => '<*.gz>' + or die "gzip failed: $GzipError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.gz" ; + gzip $input => $output + or die "Error compressing '$input': $GzipError\n"; + } + + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::Gzip> is shown below + + my $z = new IO::Compress::Gzip $output [,OPTS] + or die "IO::Compress::Gzip failed: $GzipError\n"; + +It returns an C<IO::Compress::Gzip> object on success and undef on failure. +The variable C<$GzipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Gzip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::Gzip>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item -AutoClose =E<gt> 0|1 + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being closed +once either the C<close> method is called or the C<IO::Compress::Gzip> object is +destroyed. + +This parameter defaults to 0. + +=item -Append =E<gt> 0|1 + +Opens C<$output> in append mode. + +The behaviour of this option is dependant on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data will be +append to the end if C<$output>. Otherwise C<$output> will be cleared before +any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be opened +in append mode. Otherwise the contents of the file, if any, will be truncated +before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the end +of the file via a call to C<seek> before any compressed data is written to it. +Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item -Merge =E<gt> 0|1 + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + + + +It is a fatal error to attempt to use this option when C<$output> is not an RFC +1952 data stream. + + + +There are a number of other limitations with the C<Merge> option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A fatal +error will be thrown if C<Merge> is used with an older version of zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + + +This parameter defaults to 0. + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::Gzip> by default. + + use IO::Compress::Gzip qw(:strategy); + use IO::Compress::Gzip qw(:constants); + use IO::Compress::Gzip qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + + + + + +=item -Mimimal =E<gt> 0|1 + +If specified, this option will force the creation of the smallest possible +compliant gzip header (which is exactly 10 bytes long) as defined in +RFC 1952. + +See the section titled "Compliance" in RFC 1952 for a definition +of the values used for the fields in the gzip header. + +All other parameters that control the content of the gzip header will +be ignored if this parameter is set to 1. + +This parameter defaults to 0. + +=item -Comment =E<gt> $comment + +Stores the contents of C<$comment> in the COMMENT field in +the gzip header. +By default, no comment field is written to the gzip file. + +If the C<-Strict> option is enabled, the comment can only consist of ISO +8859-1 characters plus line feed. + +If the C<-Strict> option is disabled, the comment field can contain any +character except NULL. If any null characters are present, the field +will be truncated at the first NULL. + +=item -Name =E<gt> $string + +Stores the contents of C<$string> in the gzip NAME header field. If +C<Name> is not specified, no gzip NAME field will be created. + +If the C<-Strict> option is enabled, C<$string> can only consist of ISO +8859-1 characters. + +If C<-Strict> is disabled, then C<$string> can contain any character +except NULL. If any null characters are present, the field will be +truncated at the first NULL. + +=item -Time =E<gt> $number + +Sets the MTIME field in the gzip header to $number. + +This field defaults to the time the C<IO::Compress::Gzip> object was created +if this option is not specified. + +=item -TextFlag =E<gt> 0|1 + +This parameter controls the setting of the FLG.FTEXT bit in the gzip header. It +is used to signal that the data stored in the gzip file/buffer is probably +text. + +The default is 0. + +=item -HeaderCRC =E<gt> 0|1 + +When true this parameter will set the FLG.FHCRC bit to 1 in the gzip header and +set the CRC16 header field to the CRC of the complete gzip header except the +CRC16 field itself. + +B<Note> that gzip files created with the C<HeaderCRC> flag set to 1 cannot be +read by most, if not all, of the the standard gunzip utilities, most notably +gzip version 1.2.4. You should therefore avoid using this option if you want to +maximise the portability of your gzip files. + +This parameter defaults to 0. + +=item -OS_Code =E<gt> $value + +Stores C<$value> in the gzip OS header field. A number between 0 and +255 is valid. + +If not specified, this parameter defaults to the OS code of the Operating +System this module was built on. The value 3 is used as a catch-all for all +Unix variants and unknown Operating Systems. + +=item -ExtraField =E<gt> $data + +This parameter allows additional metadata to be stored in the ExtraField in the +gzip header. An RFC1952 compliant ExtraField consists of zero or more +subfields. Each subfield consists of a two byte header followed by the subfield +data. + +The list of subfields can be supplied in any of the following formats + + -ExtraField => [$id1, $data1, + $id2, $data2, + ... + ] + -ExtraField => [ [$id1 => $data1], + [$id2 => $data2], + ... + ] + -ExtraField => { $id1 => $data1, + $id2 => $data2, + ... + } + +Where C<$id1>, C<$id2> are two byte subfield ID's. The second byte of +the ID cannot be 0, unless the C<Strict> option has been disabled. + +If you use the hash syntax, you have no control over the order in which +the ExtraSubFields are stored, plus you cannot have SubFields with +duplicate ID. + +Alternatively the list of subfields can by supplied as a scalar, thus + + -ExtraField => $rawdata + +If you use the raw format, and the C<Strict> option is enabled, +C<IO::Compress::Gzip> will check that C<$rawdata> consists of zero or more +conformant sub-fields. When C<Strict> is disabled, C<$rawdata> can +consist of any arbitrary byte stream. + +The maximum size of the Extra Field 65535 bytes. + +=item -ExtraFlags =E<gt> $value + +Sets the XFL byte in the gzip header to C<$value>. + +If this option is not present, the value stored in XFL field will be determined +by the setting of the C<Level> option. + +If C<Level =E<gt> Z_BEST_SPEED> has been specified then XFL is set to 2. +If C<Level =E<gt> Z_BEST_COMPRESSION> has been specified then XFL is set to 4. +Otherwise XFL is set to 0. + + + +=item -Strict =E<gt> 0|1 + + + +C<Strict> will optionally police the values supplied with other options +to ensure they are compliant with RFC1952. + +This option is enabled by default. + +If C<Strict> is enabled the following behavior will be policed: + +=over 5 + +=item * + +The value supplied with the C<Name> option can only contain ISO 8859-1 +characters. + +=item * + +The value supplied with the C<Comment> option can only contain ISO 8859-1 +characters plus line-feed. + +=item * + +The values supplied with the C<-Name> and C<-Comment> options cannot +contain multiple embedded nulls. + +=item * + +If an C<ExtraField> option is specified and it is a simple scalar, +it must conform to the sub-field structure as defined in RFC1952. + +=item * + +If an C<ExtraField> option is specified the second byte of the ID will be +checked in each subfield to ensure that it does not contain the reserved +value 0x00. + +=back + +When C<Strict> is disabled the following behavior will be policed: + +=over 5 + +=item * + +The value supplied with C<-Name> option can contain +any character except NULL. + +=item * + +The value supplied with C<-Comment> option can contain any character +except NULL. + +=item * + +The values supplied with the C<-Name> and C<-Comment> options can contain +multiple embedded nulls. The string written to the gzip header will +consist of the characters up to, but not including, the first embedded +NULL. + +=item * + +If an C<ExtraField> option is specified and it is a simple scalar, the +structure will not be checked. The only error is if the length is too big. + +=item * + +The ID header in an C<ExtraField> sub-field can consist of any two bytes. + +=back + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behavior as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + + syswrite $z, $data + syswrite $z, $data, $length + syswrite $z, $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + $z->flush($flush_type); + flush $z ; + flush $z $flush_type; + +Flushes any pending compressed data to the output file/buffer. + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + +Returns true on success. + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the C<close> method has been called. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file, this method will return +the underlying filehandle. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Flushes any pending compressed data and then closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Gzip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::Gzip +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 newStream + +Usage is + + $z->newStream + +TODO + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + +=head1 Importing + +A number of symbolic constants are required by some methods in +C<IO::Compress::Gzip>. None are imported by default. + +=over 5 + +=item :all + +Imports C<gzip>, C<$GzipError> and all symbolic +constants that can be used by C<IO::Compress::Gzip>. Same as doing this + + use IO::Compress::Gzip qw(gzip $GzipError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + use IO::Compress::Gzip qw(:flush :level :strategy) ; + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +=back + +For + +=head1 EXAMPLES + +TODO + + + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::AnyInflate> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for the gzip program is F<http://www.gzip.org>. + +=head1 AUTHOR + +The I<IO::Compress::Gzip> module was written by Paul Marquess, +F<pmqs@cpan.org>. The latest copy of the module can be +found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>. + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005 Paul Marquess. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + + diff --git a/ext/Compress/Zlib/lib/IO/Compress/RawDeflate.pm b/ext/Compress/Zlib/lib/IO/Compress/RawDeflate.pm new file mode 100644 index 0000000000..096f5e626b --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Compress/RawDeflate.pm @@ -0,0 +1,855 @@ +package IO::Compress::RawDeflate ; + +# create RFC1951 +# +use strict ; +use warnings; +use IO::Uncompress::RawInflate; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $RawDeflateError); + +$VERSION = '2.000_05'; +$RawDeflateError = ''; + +@ISA = qw(Exporter IO::BaseDeflate); +@EXPORT_OK = qw( $RawDeflateError rawdeflate ) ; +%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, 'rfc1951', undef, \$RawDeflateError, @_); +} + +sub rawdeflate +{ + return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1951', \$RawDeflateError, @_); +} + +1; + +__END__ + +=head1 NAME + +IO::Compress::RawDeflate - Perl interface to write RFC 1951 files/buffers + +=head1 SYNOPSIS + + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + + my $status = rawdeflate $input => $output [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + + my $z = new IO::Compress::RawDeflate $output [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->newStream(); + $z->deflateParams(); + $z->close() ; + + $RawDeflateError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + syswrite $z, $string [, $length, $offset]; + flush $z, ; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + + + +B<WARNING -- This is a Beta release>. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1951. + + + + +Note that RFC1951 data is not a good choice of compression format +to use in isolation, especially if you want to auto-detect it. + + +For reading RFC 1951 files/buffers, see the companion module +L<IO::Uncompress::RawInflate|IO::Uncompress::RawInflate>. + + +=head1 Functional Interface + +A top-level function, C<rawdeflate>, is provided to carry out "one-shot" +compression between buffers and/or files. For finer control over the compression process, see the L</"OO Interface"> section. + + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + rawdeflate $input => $output [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + + rawdeflate \%hash [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + +The functional interface needs Perl5.005 or better. + + +=head2 rawdeflate $input => $output [, OPTS] + +If the first parameter is not a hash reference C<rawdeflate> expects +at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, the input data will be read from each +element of the array in turn. The action taken by C<rawdeflate> with +each element of the array will depend on the type of data stored +in it. You can mix and match any of the types defined in this list, +excluding other array or hash references. +The complete array will be walked to ensure that it only +contains valid data types before any data is compressed. + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<rawdeflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a filename. +This file will be opened for writing and the compressed data will be +written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will +be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + + +=item A Hash Reference + +If C<$output> is a hash reference, the compressed data will be written +to C<$output{$input}> as a scalar reference. + +When C<$output> is a hash reference, C<$input> must be either a filename or +list of filenames. Anything else is an error. + + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be pushed +onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<rawdeflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 rawdeflate \%hash [, OPTS] + +If the first parameter is a hash reference, C<\%hash>, this will be used to +define both the source of uncompressed data and to control where the +compressed data is output. Each key/value pair in the hash defines a +mapping between an input filename, stored in the key, and an output +file/buffer, stored in the value. Although the input can only be a filename, +there is more flexibility to control the destination of the compressed +data. This is determined by the type of the value. Valid types are + +=over 5 + +=item undef + +If the value is C<undef> the compressed data will be written to the +value as a scalar reference. + +=item A filename + +If the value is a simple scalar, it is assumed to be a filename. This file will +be opened for writing and the compressed data will be written to it. + +=item A filehandle + +If the value is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If the value is a scalar reference, the compressed data will be stored +in the buffer that is referenced by the scalar. + + +=item A Hash Reference + +If the value is a hash reference, the compressed data will be written +to C<$hash{$input}> as a scalar reference. + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be pushed +onto the array. + +=back + +Any other type is a error. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the compressed input files/buffers will all be stored in +C<$output> as a single compressed stream. + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<rawdeflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item AutoClose =E<gt> 0|1 + +This option applies to any input or output data streams to C<rawdeflate> +that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<rawdeflate> has +completed. + +This parameter defaults to 0. + + + +=item -Append =E<gt> 0|1 + +TODO + + +=back + + + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.1951>. + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + my $input = "file1.txt"; + rawdeflate $input => "$input.1951" + or die "rawdeflate failed: $RawDeflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + rawdeflate $input => \$buffer + or die "rawdeflate failed: $RawDeflateError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + rawdeflate '</my/home/*.txt>' => '<*.1951>' + or die "rawdeflate failed: $RawDeflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.1951" ; + rawdeflate $input => $output + or die "Error compressing '$input': $RawDeflateError\n"; + } + + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::RawDeflate> is shown below + + my $z = new IO::Compress::RawDeflate $output [,OPTS] + or die "IO::Compress::RawDeflate failed: $RawDeflateError\n"; + +It returns an C<IO::Compress::RawDeflate> object on success and undef on failure. +The variable C<$RawDeflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::RawDeflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::RawDeflate>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item -AutoClose =E<gt> 0|1 + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being closed +once either the C<close> method is called or the C<IO::Compress::RawDeflate> object is +destroyed. + +This parameter defaults to 0. + +=item -Append =E<gt> 0|1 + +Opens C<$output> in append mode. + +The behaviour of this option is dependant on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data will be +append to the end if C<$output>. Otherwise C<$output> will be cleared before +any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be opened +in append mode. Otherwise the contents of the file, if any, will be truncated +before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the end +of the file via a call to C<seek> before any compressed data is written to it. +Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item -Merge =E<gt> 0|1 + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + + + +It is a fatal error to attempt to use this option when C<$output> is not an RFC +1951 data stream. + + + +There are a number of other limitations with the C<Merge> option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A fatal +error will be thrown if C<Merge> is used with an older version of zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + + +This parameter defaults to 0. + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::RawDeflate> by default. + + use IO::Compress::RawDeflate qw(:strategy); + use IO::Compress::RawDeflate qw(:constants); + use IO::Compress::RawDeflate qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + + + + + +=item -Strict =E<gt> 0|1 + + + +This is a placeholder option. + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behavior as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + + syswrite $z, $data + syswrite $z, $data, $length + syswrite $z, $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + $z->flush($flush_type); + flush $z ; + flush $z $flush_type; + +Flushes any pending compressed data to the output file/buffer. + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + +Returns true on success. + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the C<close> method has been called. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file, this method will return +the underlying filehandle. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Flushes any pending compressed data and then closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::RawDeflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::RawDeflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 newStream + +Usage is + + $z->newStream + +TODO + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + +=head1 Importing + +A number of symbolic constants are required by some methods in +C<IO::Compress::RawDeflate>. None are imported by default. + +=over 5 + +=item :all + +Imports C<rawdeflate>, C<$RawDeflateError> and all symbolic +constants that can be used by C<IO::Compress::RawDeflate>. Same as doing this + + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + use IO::Compress::RawDeflate qw(:flush :level :strategy) ; + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +=back + +For + +=head1 EXAMPLES + +TODO + + + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::AnyInflate> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for the gzip program is F<http://www.gzip.org>. + +=head1 AUTHOR + +The I<IO::Compress::RawDeflate> module was written by Paul Marquess, +F<pmqs@cpan.org>. The latest copy of the module can be +found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>. + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005 Paul Marquess. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + + diff --git a/ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm b/ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm new file mode 100644 index 0000000000..0ec9bd2ee5 --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm @@ -0,0 +1,864 @@ +package IO::Uncompress::AnyInflate ; + +# for RFC1950, RFC1951 or RFC1952 + +use strict; +use warnings; +use IO::Uncompress::Gunzip ; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); + +$VERSION = '2.000_05'; +$AnyInflateError = ''; + +@ISA = qw(Exporter IO::BaseInflate); +@EXPORT_OK = qw( $AnyInflateError anyinflate ) ; +%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + + +# TODO - allow the user to pick a set of the three formats to allow +# or just assume want to auto-detect any of the three formats. + +sub new +{ + my $pkg = shift ; + return IO::BaseInflate::new($pkg, 'any', undef, \$AnyInflateError, 0, @_); +} + +sub anyinflate +{ + return IO::BaseInflate::_inf(__PACKAGE__, 'any', \$AnyInflateError, @_) ; +} + +1 ; + +__END__ + + +=head1 NAME + +IO::Uncompress::AnyInflate - Perl interface to read RFC 1950, 1951 & 1952 files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + my $status = anyinflate $input => $output [,OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + + my $z = new IO::Uncompress::AnyInflate $input [OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $status = $z->inflateSync() + $z->trailingData() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $AnyInflateError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + + +B<WARNING -- This is a Beta release>. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + + + +This module provides a Perl interface that allows the reading of files/buffers +that conform to RFC's 1950, 1951 and 1952. + +The module will auto-detect which, if any, of the three supported compression +formats is being used. + + + +=head1 Functional Interface + +A top-level function, C<anyinflate>, is provided to carry out "one-shot" +uncompression between buffers and/or files. For finer control over the uncompression process, see the L</"OO Interface"> section. + + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + anyinflate $input => $output [,OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + + anyinflate \%hash [,OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + +The functional interface needs Perl5.005 or better. + + +=head2 anyinflate $input => $output [, OPTS] + +If the first parameter is not a hash reference C<anyinflate> expects +at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, the input data will be read from each +element of the array in turn. The action taken by C<anyinflate> with +each element of the array will depend on the type of data stored +in it. You can mix and match any of the types defined in this list, +excluding other array or hash references. +The complete array will be walked to ensure that it only +contains valid data types before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<anyinflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a filename. +This file will be opened for writing and the uncompressed data will be +written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data will +be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be stored +in C<$$output>. + + +=item A Hash Reference + +If C<$output> is a hash reference, the uncompressed data will be written +to C<$output{$input}> as a scalar reference. + +When C<$output> is a hash reference, C<$input> must be either a filename or +list of filenames. Anything else is an error. + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be pushed +onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<anyinflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 anyinflate \%hash [, OPTS] + +If the first parameter is a hash reference, C<\%hash>, this will be used to +define both the source of compressed data and to control where the +uncompressed data is output. Each key/value pair in the hash defines a +mapping between an input filename, stored in the key, and an output +file/buffer, stored in the value. Although the input can only be a filename, +there is more flexibility to control the destination of the uncompressed +data. This is determined by the type of the value. Valid types are + +=over 5 + +=item undef + +If the value is C<undef> the uncompressed data will be written to the +value as a scalar reference. + +=item A filename + +If the value is a simple scalar, it is assumed to be a filename. This file will +be opened for writing and the uncompressed data will be written to it. + +=item A filehandle + +If the value is a filehandle, the uncompressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If the value is a scalar reference, the uncompressed data will be stored +in the buffer that is referenced by the scalar. + + +=item A Hash Reference + +If the value is a hash reference, the uncompressed data will be written +to C<$hash{$input}> as a scalar reference. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be pushed +onto the array. + +=back + +Any other type is a error. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the uncompressed input files/buffers will all be stored in +C<$output> as a single uncompressed stream. + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<anyinflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item AutoClose =E<gt> 0|1 + +This option applies to any input or output data streams to C<anyinflate> +that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<anyinflate> has +completed. + +This parameter defaults to 0. + + + +=item -Append =E<gt> 0|1 + +TODO + + + +=back + + + + +=head2 Examples + +To read the contents of the file C<file1.txt.Compressed> and write the +compressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + my $input = "file1.txt.Compressed"; + my $output = "file1.txt"; + anyinflate $input => $output + or die "anyinflate failed: $AnyInflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.Compressed" + or die "Cannot open 'file1.txt.Compressed': $!\n" ; + my $buffer ; + anyinflate $input => \$buffer + or die "anyinflate failed: $AnyInflateError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.Compressed" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + anyinflate '</my/home/*.txt.Compressed>' => '</my/home/#1.txt>' + or die "anyinflate failed: $AnyInflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + for my $input ( glob "/my/home/*.txt.Compressed" ) + { + my $output = $input; + $output =~ s/.Compressed// ; + anyinflate $input => $output + or die "Error compressing '$input': $AnyInflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::AnyInflate is shown below + + + my $z = new IO::Uncompress::AnyInflate $input [OPTS] + or die "IO::Uncompress::AnyInflate failed: $AnyInflateError\n"; + +Returns an C<IO::Uncompress::AnyInflate> object on success and undef on failure. +The variable C<$AnyInflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::AnyInflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with C<$z>. +For example, to read a line from a compressed file/buffer you can use either +of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item -AutoClose =E<gt> 0|1 + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::AnyInflate object is +destroyed. + +This parameter defaults to 0. + +=item -MultiStream =E<gt> 0|1 + + + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + + + +=item -Prime =E<gt> $string + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the case, +the uncompression can be I<primed> with these bytes using this option. + +=item -Transparent =E<gt> 0|1 + +If this option is set and the input file or buffer is not compressed data, +the module will allow reading of it anyway. + +This option defaults to 1. + +=item -BlockSize =E<gt> $num + +When reading the compressed input data, IO::Uncompress::AnyInflate will read it in blocks +of C<$num> bytes. + +This option defaults to 4096. + +=item -InputLength =E<gt> $size + +When present this option will limit the number of compressed bytes read from +the input file/buffer to C<$size>. This option can be used in the situation +where there is useful data directly after the compressed data stream and you +know beforehand the exact length of the compressed data stream. + +This option is mostly used when reading from a filehandle, in which case the +file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item -Append =E<gt> 0|1 + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter of +the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method will be +overwritten by the uncompressed data. + +Defaults to 0. + +=item -Strict =E<gt> 0|1 + + + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are carried +out, when Strict is off they are not. + +The default for this option is off. + + +If the input is an RFC1950 data stream, the following will be checked: + + + + +=over 5 + +=item 1 + +The ADLER32 checksum field must be present. + +=item 2 + +The value of the ADLER32 field read must match the adler32 value of the +uncompressed data actually contained in the file. + +=back + + + +If the input is a gzip (RFC1952) data stream, the following will be checked: + + + + +=over 5 + +=item 1 + +If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the +header must match the crc16 value of the gzip header actually read. + +=item 2 + +If the gzip header contains a name field (FNAME) it consists solely of ISO +8859-1 characters. + +=item 3 + +If the gzip header contains a comment field (FCOMMENT) it consists solely of +ISO 8859-1 characters plus line-feed. + +=item 4 + +If the gzip FEXTRA header field is present it must conform to the sub-field +structure as defined in RFC1952. + +=item 5 + +The CRC32 and ISIZE trailer fields must be present. + +=item 6 + +The value of the CRC32 field read must match the crc32 value of the +uncompressed data actually contained in the gzip file. + +=item 7 + +The value of the ISIZE fields read must match the length of the uncompressed +data actually read from the file. + +=back + + + + + + +=item -ParseExtra =E<gt> 0|1 + +If the gzip FEXTRA header field is present and this option is set, it will +force the module to check that it conforms to the sub-field structure as +defined in RFC1952. + +If the C<Strict> is on it will automatically enable this option. + +Defaults to 0. + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is set +in the constructor, the uncompressed data will be appended to the C<$buffer> +parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or +a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the previous +one, is that this one will attempt to return I<exactly> C<$length> bytes. The +only circumstances that this function will not is if end-of-file or an IO error +is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or +a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> +(or C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Both paragraph mode and file +slurp mode are supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo() + +TODO + + + + + + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file, this method will return +the underlying filehandle. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::AnyInflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::AnyInflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::AnyInflate at present. + +=over 5 + +=item :all + +Imports C<anyinflate> and C<$AnyInflateError>. +Same as doing this + + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for the gzip program is F<http://www.gzip.org>. + +=head1 AUTHOR + +The I<IO::Uncompress::AnyInflate> module was written by Paul Marquess, +F<pmqs@cpan.org>. The latest copy of the module can be +found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>. + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005 Paul Marquess. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + diff --git a/ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm b/ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm new file mode 100644 index 0000000000..0d66282022 --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm @@ -0,0 +1,2641 @@ + +package IO::Uncompress::Gunzip ; + +require 5.004 ; + +# for RFC1952 + +use strict ; +use warnings; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GunzipError); + +@ISA = qw(Exporter IO::BaseInflate); +@EXPORT_OK = qw( $GunzipError gunzip ); +%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + +$GunzipError = ''; + +$VERSION = '2.000_05'; + +sub new +{ + my $pkg = shift ; + return IO::BaseInflate::new($pkg, 'rfc1952', undef, \$GunzipError, 0, @_); +} + +sub gunzip +{ + return IO::BaseInflate::_inf(__PACKAGE__, 'rfc1952', \$GunzipError, @_) ; +} + +package IO::BaseInflate ; + +use strict ; +use warnings; +use bytes; + +our ($VERSION, @EXPORT_OK, %EXPORT_TAGS); + +$VERSION = '2.000_03'; + +use Compress::Zlib 2 ; +use Compress::Zlib::Common ; +use Compress::Zlib::ParseParameters ; +use Compress::Gzip::Constants; +use Compress::Zlib::FileConstants; + +use IO::File ; +use Symbol; +use Scalar::Util qw(readonly); +use List::Util qw(min); +use Carp ; + +%EXPORT_TAGS = ( ); +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +#Exporter::export_ok_tags('all') ; + + +use constant G_EOF => 0 ; +use constant G_ERR => -1 ; + +sub smartRead +{ + my $self = $_[0]; + my $out = $_[1]; + my $size = $_[2]; + $$out = "" ; + + my $offset = 0 ; + + + if ( length *$self->{Prime} ) { + #$$out = substr(*$self->{Prime}, 0, $size, '') ; + $$out = substr(*$self->{Prime}, 0, $size) ; + substr(*$self->{Prime}, 0, $size) = '' ; + if (length $$out == $size) { + #*$self->{InputLengthRemaining} -= length $$out; + return length $$out ; + } + $offset = length $$out ; + } + + my $get_size = $size - $offset ; + + if ( defined *$self->{InputLength} ) { + #*$self->{InputLengthRemaining} += length *$self->{Prime} ; + #*$self->{InputLengthRemaining} = *$self->{InputLength} + # if *$self->{InputLengthRemaining} > *$self->{InputLength}; + $get_size = min($get_size, *$self->{InputLengthRemaining}); + } + + if (defined *$self->{FH}) + { *$self->{FH}->read($$out, $get_size, $offset) } + elsif (defined *$self->{InputEvent}) { + my $got = 1 ; + while (length $$out < $size) { + last + if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0; + } + + if (length $$out > $size ) { + #*$self->{Prime} = substr($$out, $size, length($$out), ''); + *$self->{Prime} = substr($$out, $size, length($$out)); + substr($$out, $size, length($$out)) = ''; + } + + *$self->{EventEof} = 1 if $got <= 0 ; + } + else { + no warnings 'uninitialized'; + my $buf = *$self->{Buffer} ; + $$buf = '' unless defined $$buf ; + #$$out = '' unless defined $$out ; + substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size); + *$self->{BufferOffset} += length($$out) - $offset ; + } + + *$self->{InputLengthRemaining} -= length $$out; + + $self->saveStatus(length $$out < 0 ? Z_DATA_ERROR : 0) ; + + return length $$out; +} + +sub smartSeek +{ + my $self = shift ; + my $offset = shift ; + my $truncate = shift; + #print "smartSeek to $offset\n"; + + if (defined *$self->{FH}) + { *$self->{FH}->seek($offset, SEEK_SET) } + else { + *$self->{BufferOffset} = $offset ; + substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = '' + if $truncate; + return 1; + } +} + +sub smartWrite +{ + my $self = shift ; + my $out_data = shift ; + + if (defined *$self->{FH}) { + # flush needed for 5.8.0 + defined *$self->{FH}->write($out_data, length $out_data) && + defined *$self->{FH}->flush() ; + } + else { + my $buf = *$self->{Buffer} ; + substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ; + *$self->{BufferOffset} += length($out_data) ; + return 1; + } +} + +sub smartReadExact +{ + return $_[0]->smartRead($_[1], $_[2]) == $_[2]; +} + +sub getTrailingBuffer +{ + my ($self) = $_[0]; + return "" if defined *$self->{FH} || defined *$self->{InputEvent} ; + + my $buf = *$self->{Buffer} ; + my $offset = *$self->{BufferOffset} ; + return substr($$buf, $offset, -1) ; +} + +sub smartEof +{ + my ($self) = $_[0]; + if (defined *$self->{FH}) + { *$self->{FH}->eof() } + elsif (defined *$self->{InputEvent}) + { *$self->{EventEof} } + else + { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) } +} + +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 @_ ; + + #print "saveErrorString: " . ${ *$self->{Error} } . "\n" ; + return $retval; +} + +sub error +{ + my $self = shift ; + return ${ *$self->{Error} } ; +} + +sub errorNo +{ + my $self = shift ; + return *$self->{ErrorNo}; +} + +sub HeaderError +{ + my ($self) = shift; + return $self->saveErrorString(undef, "Header Error: $_[0]", Z_DATA_ERROR); +} + +sub TrailerError +{ + my ($self) = shift; + return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", Z_DATA_ERROR); +} + +sub TruncatedHeader +{ + my ($self) = shift; + return $self->HeaderError("Truncated in $_[0] Section"); +} + +sub isZipMagic +{ + my $buffer = shift ; + return 0 if length $buffer < 4 ; + my $sig = unpack("V", $buffer) ; + return $sig == 0x04034b50 ; +} + +sub isGzipMagic +{ + my $buffer = shift ; + return 0 if length $buffer < GZIP_ID_SIZE ; + my ($id1, $id2) = unpack("C C", $buffer) ; + return $id1 == GZIP_ID1 && $id2 == GZIP_ID2 ; +} + +sub isZlibMagic +{ + my $buffer = shift ; + return 0 if length $buffer < ZLIB_HEADER_SIZE ; + my $hdr = unpack("n", $buffer) ; + return $hdr % 31 == 0 ; +} + +sub _isRaw +{ + my $self = shift ; + my $magic = shift ; + + $magic = '' unless defined $magic ; + + my $buffer = ''; + + $self->smartRead(\$buffer, *$self->{BlockSize}) >= 0 + or return $self->saveErrorString(undef, "No data to read"); + + my $temp_buf = $magic . $buffer ; + *$self->{HeaderPending} = $temp_buf ; + $buffer = ''; + my $status = *$self->{Inflate}->inflate($temp_buf, $buffer) ; + my $buf_len = *$self->{Inflate}->inflateCount(); + + # zlib before 1.2 needs an extra byte after the compressed data + # for RawDeflate + if ($status == Z_OK && $self->smartEof()) { + my $byte = ' '; + $status = *$self->{Inflate}->inflate(\$byte, $buffer) ; + return $self->saveErrorString(undef, "Inflation Error: $status", $status) + unless $self->saveStatus($status) == Z_OK || $status == Z_STREAM_END ; + $buf_len += *$self->{Inflate}->inflateCount(); + } + + return $self->saveErrorString(undef, "unexpected end of file", Z_DATA_ERROR) + if $self->saveStatus($status) != Z_STREAM_END && $self->smartEof() ; + + return $self->saveErrorString(undef, "Inflation Error: $status", $status) + unless $status == Z_OK || $status == Z_STREAM_END ; + + if ($status == Z_STREAM_END) { + if (*$self->{MultiStream} + && (length $temp_buf || ! $self->smartEof())){ + *$self->{NewStream} = 1 ; + *$self->{EndStream} = 0 ; + *$self->{Prime} = $temp_buf . *$self->{Prime} ; + } + else { + *$self->{EndStream} = 1 ; + *$self->{Trailing} = $temp_buf . $self->getTrailingBuffer(); + } + } + *$self->{HeaderPending} = $buffer ; + *$self->{InflatedBytesRead} = $buf_len ; + *$self->{TotalInflatedBytesRead} += $buf_len ; + *$self->{Type} = 'rfc1951'; + + $self->saveStatus(Z_OK); + + return { + 'Type' => 'rfc1951', + 'HeaderLength' => 0, + 'TrailerLength' => 0, + 'Header' => '' + }; +} + +sub _guessCompression +{ + my $self = shift ; + + # Check raw first in case the first few bytes happen to match + # the signatures of gzip/deflate. + my $got = $self->_isRaw() ; + return $got if defined $got ; + + *$self->{Prime} = *$self->{HeaderPending} . *$self->{Prime} ; + *$self->{HeaderPending} = ''; + *$self->{Inflate}->inflateReset(); + + my $magic = '' ; + my $status ; + $self->smartReadExact(\$magic, GZIP_ID_SIZE) + or return $self->HeaderError("Minimum header size is " . + GZIP_ID_SIZE . " bytes") ; + + if (isGzipMagic($magic)) { + $status = $self->_readGzipHeader($magic); + delete *$self->{Transparent} if ! defined $status ; + return $status ; + } + elsif ( $status = $self->_readDeflateHeader($magic) ) { + return $status ; + } + + *$self->{Prime} = $magic . *$self->{HeaderPending} . *$self->{Prime} ; + *$self->{HeaderPending} = ''; + $self->saveErrorString(undef, "unknown compression format", Z_DATA_ERROR); +} + +sub _readFullGzipHeader($) +{ + my ($self) = @_ ; + my $magic = '' ; + + $self->smartReadExact(\$magic, GZIP_ID_SIZE); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") + if length $magic != GZIP_ID_SIZE ; + + + return $self->HeaderError("Bad Magic") + if ! isGzipMagic($magic) ; + + my $status = $self->_readGzipHeader($magic); + delete *$self->{Transparent} if ! defined $status ; + return $status ; +} + +sub _readGzipHeader($) +{ + my ($self, $magic) = @_ ; + my ($HeaderCRC) ; + my ($buffer) = '' ; + + $self->smartReadExact(\$buffer, GZIP_MIN_HEADER_SIZE - GZIP_ID_SIZE) + or return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + # now split out the various parts + my ($cm, $flag, $mtime, $xfl, $os) = unpack("C C V C C", $buffer) ; + + $cm == GZIP_CM_DEFLATED + or return $self->HeaderError("Not Deflate (CM is $cm)") ; + + # check for use of reserved bits + return $self->HeaderError("Use of Reserved Bits in FLG field.") + if $flag & GZIP_FLG_RESERVED ; + + my $EXTRA ; + my @EXTRA = () ; + if ($flag & GZIP_FLG_FEXTRA) { + $EXTRA = "" ; + $self->smartReadExact(\$buffer, GZIP_FEXTRA_HEADER_SIZE) + or return $self->TruncatedHeader("FEXTRA Length") ; + + my ($XLEN) = unpack("v", $buffer) ; + $self->smartReadExact(\$EXTRA, $XLEN) + or return $self->TruncatedHeader("FEXTRA Body"); + $keep .= $buffer . $EXTRA ; + + if ($XLEN && *$self->{'ParseExtra'}) { + my $offset = 0 ; + while ($offset < $XLEN) { + + return $self->TruncatedHeader("FEXTRA Body") + if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; + + my $id = substr($EXTRA, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); + $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE ; + + return $self->HeaderError("SubField ID 2nd byte is 0x00") + if *$self->{Strict} && substr($id, 1, 1) eq "\x00" ; + + my ($subLen) = unpack("v", substr($EXTRA, $offset, + GZIP_FEXTRA_SUBFIELD_LEN_SIZE)) ; + $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; + + return $self->TruncatedHeader("FEXTRA Body") + if $offset + $subLen > $XLEN ; + + push @EXTRA, [$id => substr($EXTRA, $offset, $subLen)]; + $offset += $subLen ; + } + } + } + + my $origname ; + if ($flag & GZIP_FLG_FNAME) { + $origname = "" ; + while (1) { + $self->smartReadExact(\$buffer, 1) + or return $self->TruncatedHeader("FNAME"); + last if $buffer eq GZIP_NULL_BYTE ; + $origname .= $buffer + } + $keep .= $origname . GZIP_NULL_BYTE ; + + return $self->HeaderError("Non ISO 8859-1 Character found in Name") + if *$self->{Strict} && $origname =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; + } + + my $comment ; + if ($flag & GZIP_FLG_FCOMMENT) { + $comment = ""; + while (1) { + $self->smartReadExact(\$buffer, 1) + or return $self->TruncatedHeader("FCOMMENT"); + last if $buffer eq GZIP_NULL_BYTE ; + $comment .= $buffer + } + $keep .= $comment . GZIP_NULL_BYTE ; + + return $self->HeaderError("Non ISO 8859-1 Character found in Comment") + if *$self->{Strict} && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o ; + } + + if ($flag & GZIP_FLG_FHCRC) { + $self->smartReadExact(\$buffer, GZIP_FHCRC_SIZE) + or return $self->TruncatedHeader("FHCRC"); + + $HeaderCRC = unpack("v", $buffer) ; + my $crc16 = crc32($keep) & 0xFF ; + + return $self->HeaderError("CRC16 mismatch.") + if *$self->{Strict} && $crc16 != $HeaderCRC; + + $keep .= $buffer ; + } + + # Assume compression method is deflated for xfl tests + #if ($xfl) { + #} + + *$self->{Type} = 'rfc1952'; + + return { + 'Type' => 'rfc1952', + 'HeaderLength' => length $keep, + 'TrailerLength' => GZIP_TRAILER_SIZE, + 'Header' => $keep, + 'isMinimalHeader' => $keep eq GZIP_MINIMUM_HEADER ? 1 : 0, + + 'MethodID' => $cm, + 'MethodName' => $cm == GZIP_CM_DEFLATED ? "Deflated" : "Unknown" , + 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0, + 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0, + 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0, + 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0, + 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0, + 'Name' => $origname, + 'Comment' => $comment, + 'Time' => $mtime, + 'OsID' => $os, + 'OsName' => defined $GZIP_OS_Names{$os} + ? $GZIP_OS_Names{$os} : "Unknown", + 'HeaderCRC' => $HeaderCRC, + 'Flags' => $flag, + 'ExtraFlags' => $xfl, + 'ExtraFieldRaw' => $EXTRA, + 'ExtraField' => [ @EXTRA ], + + + #'CompSize'=> $compsize, + #'CRC32'=> $CRC32, + #'OrigSize'=> $ISIZE, + } +} + +sub _readFullZipHeader($) +{ + my ($self) = @_ ; + my $magic = '' ; + + $self->smartReadExact(\$magic, 4); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + 30 . " bytes") + if length $magic != 4 ; + + + return $self->HeaderError("Bad Magic") + if ! isZipMagic($magic) ; + + my $status = $self->_readZipHeader($magic); + delete *$self->{Transparent} if ! defined $status ; + return $status ; +} + +sub _readZipHeader($) +{ + my ($self, $magic) = @_ ; + my ($HeaderCRC) ; + my ($buffer) = '' ; + + $self->smartReadExact(\$buffer, 30 - 4) + or return $self->HeaderError("Minimum header size is " . + 30 . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + my $extractVersion = unpack ("v", substr($buffer, 4-4, 2)); + my $gpFlag = unpack ("v", substr($buffer, 6-4, 2)); + my $compressedMethod = unpack ("v", substr($buffer, 8-4, 2)); + my $lastModTime = unpack ("v", substr($buffer, 10-4, 2)); + my $lastModDate = unpack ("v", substr($buffer, 12-4, 2)); + my $crc32 = unpack ("v", substr($buffer, 14-4, 4)); + my $compressedLength = unpack ("V", substr($buffer, 18-4, 4)); + my $uncompressedLength = unpack ("V", substr($buffer, 22-4, 4)); + my $filename_length = unpack ("v", substr($buffer, 26-4, 2)); + my $extra_length = unpack ("v", substr($buffer, 28-4, 2)); + + my $filename; + my $extraField; + + if ($filename_length) + { + $self->smartReadExact(\$filename, $filename_length) + or return $self->HeaderError("xxx"); + $keep .= $filename ; + } + + if ($extra_length) + { + $self->smartReadExact(\$extraField, $extra_length) + or return $self->HeaderError("xxx"); + $keep .= $extraField ; + } + + *$self->{Type} = 'zip'; + + return { + 'Type' => 'zip', + 'HeaderLength' => length $keep, + 'TrailerLength' => $gpFlag & 0x08 ? 16 : 0, + 'Header' => $keep, + +# 'MethodID' => $cm, +# 'MethodName' => $cm == GZIP_CM_DEFLATED ? "Deflated" : "Unknown" , +# 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0, +# 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0, +# 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0, +# 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0, +# 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0, +# 'Name' => $origname, +# 'Comment' => $comment, +# 'Time' => $mtime, +# 'OsID' => $os, +# 'OsName' => defined $GZIP_OS_Names{$os} +# ? $GZIP_OS_Names{$os} : "Unknown", +# 'HeaderCRC' => $HeaderCRC, +# 'Flags' => $flag, +# 'ExtraFlags' => $xfl, +# 'ExtraFieldRaw' => $EXTRA, +# 'ExtraField' => [ @EXTRA ], + + + #'CompSize'=> $compsize, + #'CRC32'=> $CRC32, + #'OrigSize'=> $ISIZE, + } +} + +sub bits +{ + my $data = shift ; + my $offset = shift ; + my $mask = shift ; + + ($data >> $offset ) & $mask & 0xFF ; +} + + +sub _readDeflateHeader +{ + my ($self, $buffer) = @_ ; + + if (! $buffer) { + $self->smartReadExact(\$buffer, ZLIB_HEADER_SIZE); + + *$self->{HeaderPending} = $buffer ; + + return $self->HeaderError("Header size is " . + ZLIB_HEADER_SIZE . " bytes") + if length $buffer != ZLIB_HEADER_SIZE; + + return $self->HeaderError("CRC mismatch.") + if ! isZlibMagic($buffer) ; + } + + my ($CMF, $FLG) = unpack "C C", $buffer; + my $FDICT = bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ), + + my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ; + $cm == ZLIB_CMF_CM_DEFLATED + or return $self->HeaderError("Not Deflate (CM is $cm)") ; + + my $DICTID; + if ($FDICT) { + $self->smartReadExact(\$buffer, ZLIB_FDICT_SIZE) + or return $self->TruncatedHeader("FDICT"); + + $DICTID = unpack("N", $buffer) ; + } + + *$self->{Type} = 'rfc1950'; + + return { + 'Type' => 'rfc1950', + 'HeaderLength' => ZLIB_HEADER_SIZE, + 'TrailerLength' => ZLIB_TRAILER_SIZE, + 'Header' => $buffer, + + CMF => $CMF , + CM => bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS ), + CINFO => bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS ), + FLG => $FLG , + FCHECK => bits($FLG, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS), + FDICT => bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ), + FLEVEL => bits($FLG, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS ), + DICTID => $DICTID , + +}; +} + + +sub checkParams +{ + my $class = shift ; + my $type = shift ; + + + my $Valid = { + #'Input' => [Parse_store_ref, undef], + + 'BlockSize' => [Parse_unsigned, 16 * 1024], + 'AutoClose' => [Parse_boolean, 0], + 'Strict' => [Parse_boolean, 0], + #'Lax' => [Parse_boolean, 1], + 'Append' => [Parse_boolean, 0], + 'Prime' => [Parse_any, undef], + 'MultiStream' => [Parse_boolean, 0], + 'Transparent' => [Parse_any, 1], + 'Scan' => [Parse_boolean, 0], + 'InputLength' => [Parse_unsigned, undef], + + #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0, + # ContinueAfterEof + } ; + + $Valid->{'ParseExtra'} = [Parse_boolean, 0] + if $type eq 'rfc1952' ; + + my $got = Compress::Zlib::ParseParameters::new(); + + $got->parse($Valid, @_ ) + or croak "$class: $got->{Error}" ; + + return $got; +} + +sub new +{ + my $class = shift ; + my $type = shift ; + my $got = shift; + my $error_ref = shift ; + my $append_mode = shift ; + + croak("$class: Missing Input parameter") + if ! @_ && ! $got ; + + my $inValue = shift ; + + if (! $got) + { + $got = checkParams($class, $type, @_) + or return undef ; + } + + my $inType = whatIsInput($inValue, 1); + + ckInputParam($class, $inValue, $error_ref, 1) + or return undef ; + + my $obj = bless Symbol::gensym(), ref($class) || $class; + tie *$obj, $obj if $] >= 5.005; + + + $$error_ref = '' ; + *$obj->{Error} = $error_ref ; + *$obj->{InNew} = 1; + + if ($inType eq 'buffer' || $inType eq 'code') { + *$obj->{Buffer} = $inValue ; + *$obj->{InputEvent} = $inValue + if $inType eq 'code' ; + } + else { + if ($inType eq 'handle') { + *$obj->{FH} = $inValue ; + *$obj->{Handle} = 1 ; + # Need to rewind for Scan + #seek(*$obj->{FH}, 0, SEEK_SET) if $got->value('Scan'); + *$obj->{FH}->seek(0, SEEK_SET) if $got->value('Scan'); + } + else { + my $mode = '<'; + $mode = '+<' if $got->value('Scan'); + *$obj->{StdIO} = ($inValue eq '-'); + *$obj->{FH} = new IO::File "$mode $inValue" + or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ; + *$obj->{LineNo} = 0; + } + # Setting STDIN to binmode causes grief + setBinModeInput(*$obj->{FH}) ; + + my $buff = "" ; + *$obj->{Buffer} = \$buff ; + } + + + *$obj->{InputLength} = $got->parsed('InputLength') + ? $got->value('InputLength') + : undef ; + *$obj->{InputLengthRemaining} = $got->value('InputLength'); + *$obj->{BufferOffset} = 0 ; + *$obj->{AutoClose} = $got->value('AutoClose'); + *$obj->{Strict} = $got->value('Strict'); + #*$obj->{Strict} = ! $got->value('Lax'); + *$obj->{BlockSize} = $got->value('BlockSize'); + *$obj->{Append} = $got->value('Append'); + *$obj->{AppendOutput} = $append_mode || $got->value('Append'); + *$obj->{Transparent} = $got->value('Transparent'); + *$obj->{MultiStream} = $got->value('MultiStream'); + *$obj->{Scan} = $got->value('Scan'); + *$obj->{ParseExtra} = $got->value('ParseExtra') + || $got->value('Strict') ; + #|| ! $got->value('Lax') ; + *$obj->{Type} = $type; + *$obj->{Prime} = $got->value('Prime') || '' ; + *$obj->{Pending} = ''; + *$obj->{Plain} = 0; + *$obj->{PlainBytesRead} = 0; + *$obj->{InflatedBytesRead} = 0; + *$obj->{ISize} = 0; + *$obj->{TotalInflatedBytesRead} = 0; + *$obj->{NewStream} = 0 ; + *$obj->{EventEof} = 0 ; + *$obj->{ClassName} = $class ; + + my $status; + + if (*$obj->{Scan}) + { + (*$obj->{Inflate}, $status) = new Compress::Zlib::InflateScan + -CRC32 => $type eq 'rfc1952' || + $type eq 'any', + -ADLER32 => $type eq 'rfc1950' || + $type eq 'any', + -WindowBits => - MAX_WBITS ; + } + else + { + (*$obj->{Inflate}, $status) = new Compress::Zlib::Inflate + -AppendOutput => 1, + -CRC32 => $type eq 'rfc1952' || + $type eq 'any', + -ADLER32 => $type eq 'rfc1950' || + $type eq 'any', + -WindowBits => - MAX_WBITS ; + } + + return $obj->saveErrorString(undef, "Could not create Inflation object: $status") + if $obj->saveStatus($status) != Z_OK ; + + if ($type eq 'rfc1952') + { + *$obj->{Info} = $obj->_readFullGzipHeader() ; + } + elsif ($type eq 'zip') + { + *$obj->{Info} = $obj->_readFullZipHeader() ; + } + elsif ($type eq 'rfc1950') + { + *$obj->{Info} = $obj->_readDeflateHeader() ; + } + elsif ($type eq 'rfc1951') + { + *$obj->{Info} = $obj->_isRaw() ; + } + elsif ($type eq 'any') + { + *$obj->{Info} = $obj->_guessCompression() ; + } + + if (! defined *$obj->{Info}) + { + return undef unless *$obj->{Transparent}; + + *$obj->{Type} = 'plain'; + *$obj->{Plain} = 1; + *$obj->{PlainBytesRead} = length *$obj->{HeaderPending} ; + } + + push @{ *$obj->{InfoList} }, *$obj->{Info} ; + *$obj->{Pending} = *$obj->{HeaderPending} + if *$obj->{Plain} || *$obj->{Type} eq 'rfc1951'; + + $obj->saveStatus(0) ; + *$obj->{InNew} = 0; + + return $obj; +} + +#sub _inf +#{ +# my $class = shift ; +# my $type = shift ; +# my $error_ref = shift ; +# +# my $name = (caller(1))[3] ; +# +# croak "$name: expected at least 2 parameters\n" +# unless @_ >= 2 ; +# +# my $input = shift ; +# my $output = shift ; +# +# ckInOutParams($name, $input, $output, $error_ref) +# or return undef ; +# +# my $outType = whatIs($output); +# +# my $gunzip = new($class, $type, $error_ref, 1, $input, @_) +# or return undef ; +# +# my $fh ; +# if ($outType eq 'filename') { +# my $mode = '>' ; +# $mode = '>>' +# if *$gunzip->{Append} ; +# $fh = new IO::File "$mode $output" +# or return $gunzip->saveErrorString(undef, "cannot open file '$output': $!", $!) ; +# } +# +# if ($outType eq 'handle') { +# $fh = $output; +# if (*$gunzip->{Append}) { +# seek($fh, 0, SEEK_END) +# or return $gunzip->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; +# } +# } +# +# my $buff = '' ; +# $buff = $output if $outType eq 'buffer' ; +# my $status ; +# while (($status = $gunzip->read($buff)) > 0) { +# if ($fh) { +# print $fh $buff +# or return $gunzip->saveErrorString(undef, "Error writing to output file: $!", $!); +# } +# } +# +# return undef +# if $status < 0 ; +# +# $gunzip->close() +# or return undef ; +# +# if ( $outType eq 'filename' || +# ($outType eq 'handle' && *$gunzip->{AutoClose})) { +# $fh->close() +# or return $gunzip->saveErrorString(undef, $!, $!); +# } +# +# return 1 ; +#} + +sub _inf +{ + my $class = shift ; + my $type = shift ; + my $error_ref = shift ; + + my $name = (caller(1))[3] ; + + croak "$name: expected at least 1 parameters\n" + unless @_ >= 1 ; + + my $input = shift ; + my $haveOut = @_ ; + my $output = shift ; + + my $x = new Validator($class, $type, $error_ref, $name, $input, $output) + or return undef ; + + push @_, $output if $haveOut && $x->{Hash}; + + my $got = checkParams($name, $type, @_) + or return undef ; + + $x->{Got} = $got ; + + if ($x->{Hash}) + { + while (my($k, $v) = each %$input) + { + $v = \$input->{$k} + unless defined $v ; + + _singleTarget($x, 1, $k, $v, @_) + or return undef ; + } + + return keys %$input ; + } + + if ($x->{GlobMap}) + { + $x->{oneInput} = 1 ; + foreach my $pair (@{ $x->{Pairs} }) + { + my ($from, $to) = @$pair ; + _singleTarget($x, 1, $from, $to, @_) + or return undef ; + } + + return scalar @{ $x->{Pairs} } ; + } + + #if ($x->{outType} eq 'array' || $x->{outType} eq 'hash') + if (! $x->{oneOutput} ) + { + my $inFile = ($x->{inType} eq 'filenames' + || $x->{inType} eq 'filename'); + + $x->{inType} = $inFile ? 'filename' : 'buffer'; + my $ot = $x->{outType} ; + $x->{outType} = 'buffer'; + + foreach my $in ($x->{oneInput} ? $input : @$input) + { + my $out ; + $x->{oneInput} = 1 ; + + _singleTarget($x, $inFile, $in, \$out, @_) + or return undef ; + + if ($ot eq 'array') + { push @$output, \$out } + else + { $output->{$in} = \$out } + } + + return 1 ; + } + + # finally the 1 to 1 and n to 1 + return _singleTarget($x, 1, $input, $output, @_); + + croak "should not be here" ; +} + +sub retErr +{ + my $x = shift ; + my $string = shift ; + + ${ $x->{Error} } = $string ; + + return undef ; +} + +sub _singleTarget +{ + my $x = shift ; + my $inputIsFilename = shift; + my $input = shift; + my $output = shift; + + $x->{buff} = '' ; + + my $fh ; + if ($x->{outType} eq 'filename') { + my $mode = '>' ; + $mode = '>>' + if $x->{Got}->value('Append') ; + $x->{fh} = new IO::File "$mode $output" + or return retErr($x, "cannot open file '$output': $!") ; + setBinModeOutput($x->{fh}); + + } + + elsif ($x->{outType} eq 'handle') { + $x->{fh} = $output; + setBinModeOutput($x->{fh}); + if ($x->{Got}->value('Append')) { + seek($x->{fh}, 0, SEEK_END) + or return retErr($x, "Cannot seek to end of output filehandle: $!") ; + } + } + + + elsif ($x->{outType} eq 'buffer' ) + { + $$output = '' + unless $x->{Got}->value('Append'); + $x->{buff} = $output ; + } + + if ($x->{oneInput}) + { + defined _rd2($x, $input, $inputIsFilename) + or return undef; + } + else + { + my $inputIsFilename = ($x->{inType} ne 'array'); + + for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) + { + defined _rd2($x, $element, $inputIsFilename) + or return undef ; + } + } + + + if ( ($x->{outType} eq 'filename' && $output ne '-') || + ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) { + $x->{fh}->close() + or return retErr($x, $!); + #or return $gunzip->saveErrorString(undef, $!, $!); + delete $x->{fh}; + } + + return 1 ; +} + +sub _rd2 +{ + my $x = shift ; + my $input = shift; + my $inputIsFilename = shift; + + my $gunzip = new($x->{Class}, $x->{Type}, $x->{Got}, $x->{Error}, 1, $input, @_) + or return undef ; + + my $status ; + my $fh = $x->{fh}; + + while (($status = $gunzip->read($x->{buff})) > 0) { + if ($fh) { + print $fh $x->{buff} + or return $gunzip->saveErrorString(undef, "Error writing to output file: $!", $!); + $x->{buff} = '' ; + } + } + + return undef + if $status < 0 ; + + $gunzip->close() + or return undef ; + + return 1 ; +} + +sub TIEHANDLE +{ + return $_[0] if ref($_[0]); + die "OOPS\n" ; + +} + +sub UNTIE +{ + my $self = shift ; +} + + +sub getHeaderInfo +{ + my $self = shift ; + return *$self->{Info}; +} + +sub _raw_read +{ + # return codes + # >0 - ok, number of bytes read + # =0 - ok, eof + # <0 - not ok + + my $self = shift ; + + return G_EOF if *$self->{Closed} ; + #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; + return G_EOF if *$self->{EndStream} ; + + my $buffer = shift ; + my $scan_mode = shift ; + + if (*$self->{Plain}) { + my $tmp_buff ; + my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ; + + return $self->saveErrorString(G_ERR, "Error reading data: $!", $!) + if $len < 0 ; + + if ($len == 0 ) { + *$self->{EndStream} = 1 ; + } + else { + *$self->{PlainBytesRead} += $len ; + $$buffer .= $tmp_buff; + } + + return $len ; + } + + if (*$self->{NewStream}) { + *$self->{NewStream} = 0 ; + *$self->{EndStream} = 0 ; + *$self->{Inflate}->inflateReset(); + + if (*$self->{Type} eq 'rfc1952') + { + *$self->{Info} = $self->_readFullGzipHeader() ; + } + elsif (*$self->{Type} eq 'zip') + { + *$self->{Info} = $self->_readFullZipHeader() ; + } + elsif (*$self->{Type} eq 'rfc1950') + { + *$self->{Info} = $self->_readDeflateHeader() ; + } + elsif (*$self->{Type} eq 'rfc1951') + { + *$self->{Info} = $self->_isRaw() ; + *$self->{Pending} = *$self->{HeaderPending} + if defined *$self->{Info} ; + } + + return G_ERR unless defined *$self->{Info} ; + + push @{ *$self->{InfoList} }, *$self->{Info} ; + + if (*$self->{Type} eq 'rfc1951') { + $$buffer .= *$self->{Pending} ; + my $len = length *$self->{Pending} ; + *$self->{Pending} = ''; + return $len; + } + } + + my $temp_buf ; + my $status = $self->smartRead(\$temp_buf, *$self->{BlockSize}) ; + return $self->saveErrorString(G_ERR, "Error Reading Data") + if $status < 0 ; + + if ($status == 0 ) { + *$self->{Closed} = 1 ; + *$self->{EndStream} = 1 ; + return $self->saveErrorString(G_ERR, "unexpected end of file", Z_DATA_ERROR); + } + + my $before_len = defined $$buffer ? length $$buffer : 0 ; + $status = *$self->{Inflate}->inflate(\$temp_buf, $buffer) ; + + return $self->saveErrorString(G_ERR, "Inflation Error: $status") + unless $self->saveStatus($status) == Z_OK || $status == Z_STREAM_END ; + + my $buf_len = *$self->{Inflate}->inflateCount(); + + # zlib before 1.2 needs an extra byte after the compressed data + # for RawDeflate + if ($status == Z_OK && *$self->{Type} eq 'rfc1951' && $self->smartEof()) { + my $byte = ' '; + $status = *$self->{Inflate}->inflate(\$byte, $buffer) ; + + $buf_len += *$self->{Inflate}->inflateCount(); + + return $self->saveErrorString(G_ERR, "Inflation Error: $status") + unless $self->saveStatus($status) == Z_OK || $status == Z_STREAM_END ; + } + + + return $self->saveErrorString(G_ERR, "unexpected end of file", Z_DATA_ERROR) + if $status != Z_STREAM_END && $self->smartEof() ; + + *$self->{InflatedBytesRead} += $buf_len ; + *$self->{TotalInflatedBytesRead} += $buf_len ; + my $rest = GZIP_ISIZE_MAX - *$self->{ISize} ; + if ($buf_len > $rest) { + *$self->{ISize} = $buf_len - $rest - 1; + } + else { + *$self->{ISize} += $buf_len ; + } + + if ($status == Z_STREAM_END) { + + *$self->{EndStream} = 1 ; + + if (*$self->{Type} eq 'rfc1951' || ! *$self->{Info}{TrailerLength}) + { + *$self->{Trailing} = $temp_buf . $self->getTrailingBuffer(); + } + else + { + # Only rfc1950 & 1952 have a trailer + + my $trailer_size = *$self->{Info}{TrailerLength} ; + + #if ($scan_mode) { + # my $offset = *$self->{Inflate}->getLastBufferOffset(); + # substr($temp_buf, 0, $offset) = '' ; + #} + + if (length $temp_buf < $trailer_size) { + my $buff; + my $want = $trailer_size - length $temp_buf; + my $got = $self->smartRead(\$buff, $want) ; + if ($got != $want && *$self->{Strict} ) { + my $len = length($temp_buf) + length($buff); + return $self->TrailerError("trailer truncated. Expected " . + "$trailer_size bytes, got $len"); + } + $temp_buf .= $buff; + } + + if (length $temp_buf >= $trailer_size) { + + #my $trailer = substr($temp_buf, 0, $trailer_size, '') ; + my $trailer = substr($temp_buf, 0, $trailer_size) ; + substr($temp_buf, 0, $trailer_size) = '' ; + + if (*$self->{Type} eq 'rfc1952') { + # Check CRC & ISIZE + my ($CRC32, $ISIZE) = unpack("V V", $trailer) ; + *$self->{Info}{CRC32} = $CRC32; + *$self->{Info}{ISIZE} = $ISIZE; + + if (*$self->{Strict}) { + return $self->TrailerError("CRC mismatch") + if $CRC32 != *$self->{Inflate}->crc32() ; + + my $exp_isize = *$self->{ISize}; + return $self->TrailerError("ISIZE mismatch. Got $ISIZE" + . ", expected $exp_isize") + if $ISIZE != $exp_isize ; + } + } + elsif (*$self->{Type} eq 'zip') { + # Check CRC & ISIZE + my ($sig, $CRC32, $cSize, $uSize) = unpack("V V V V", $trailer) ; + return $self->TrailerError("Data Descriptor signature") + if $sig != 0x08074b50; + + if (*$self->{Strict}) { + return $self->TrailerError("CRC mismatch") + if $CRC32 != *$self->{Inflate}->crc32() ; + + } + } + elsif (*$self->{Type} eq 'rfc1950') { + my $ADLER32 = unpack("N", $trailer) ; + *$self->{Info}{ADLER32} = $ADLER32; + return $self->TrailerError("CRC mismatch") + if *$self->{Strict} && $ADLER32 != *$self->{Inflate}->adler32() ; + + } + + if (*$self->{MultiStream} + && (length $temp_buf || ! $self->smartEof())){ + *$self->{NewStream} = 1 ; + *$self->{EndStream} = 0 ; + *$self->{Prime} = $temp_buf . *$self->{Prime} ; + return $buf_len ; + } + } + + *$self->{Trailing} = $temp_buf .$self->getTrailingBuffer(); + } + } + + + # return the number of uncompressed bytes read + return $buf_len ; +} + +#sub isEndStream +#{ +# my $self = shift ; +# return *$self->{NewStream} || +# *$self->{EndStream} ; +#} + +sub streamCount +{ + my $self = shift ; + return 1 if ! defined *$self->{InfoList}; + return scalar @{ *$self->{InfoList} } ; +} + +sub read +{ + # return codes + # >0 - ok, number of bytes read + # =0 - ok, eof + # <0 - not ok + + my $self = shift ; + + return G_EOF if *$self->{Closed} ; + return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; + + my $buffer ; + + #croak(*$self->{ClassName} . "::read: buffer parameter is read-only") + # if Compress::Zlib::_readonly_ref($_[0]); + + if (ref $_[0] ) { + croak(*$self->{ClassName} . "::read: buffer parameter is read-only") + if readonly(${ $_[0] }); + + croak *$self->{ClassName} . "::read: not a scalar reference $_[0]" + unless ref $_[0] eq 'SCALAR' ; + $buffer = $_[0] ; + } + else { + croak(*$self->{ClassName} . "::read: buffer parameter is read-only") + if readonly($_[0]); + + $buffer = \$_[0] ; + } + + my $length = $_[1] ; + my $offset = $_[2] || 0; + + # the core read will return 0 if asked for 0 bytes + return 0 if defined $length && $length == 0 ; + + $length = $length || 0; + + croak(*$self->{ClassName} . "::read: length parameter is negative") + if $length < 0 ; + + $$buffer = '' unless *$self->{AppendOutput} || $offset ; + + # Short-circuit if this is a simple read, with no length + # or offset specified. + unless ( $length || $offset) { + if (length *$self->{Pending}) { + $$buffer .= *$self->{Pending} ; + my $len = length *$self->{Pending}; + *$self->{Pending} = '' ; + return $len ; + } + else { + my $len = 0; + $len = $self->_raw_read($buffer) + while ! *$self->{EndStream} && $len == 0 ; + return $len ; + } + } + + # Need to jump through more hoops - either length or offset + # or both are specified. + #*$self->{Pending} = '' if ! length *$self->{Pending} ; + my $out_buffer = \*$self->{Pending} ; + + while (! *$self->{EndStream} && length($$out_buffer) < $length) + { + my $buf_len = $self->_raw_read($out_buffer); + return $buf_len + if $buf_len < 0 ; + } + + $length = length $$out_buffer + if length($$out_buffer) < $length ; + + if ($offset) { + $$buffer .= "\x00" x ($offset - length($$buffer)) + if $offset > length($$buffer) ; + #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ; + substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ; + substr($$out_buffer, 0, $length) = '' ; + } + else { + #$$buffer .= substr($$out_buffer, 0, $length, '') ; + $$buffer .= substr($$out_buffer, 0, $length) ; + substr($$out_buffer, 0, $length) = '' ; + } + + return $length ; +} + +sub _getline +{ + my $self = shift ; + + # Slurp Mode + if ( ! defined $/ ) { + my $data ; + 1 while $self->read($data) > 0 ; + return \$data ; + } + + # Paragraph Mode + if ( ! length $/ ) { + my $paragraph ; + while ($self->read($paragraph) > 0 ) { + if ($paragraph =~ s/^(.*?\n\n+)//s) { + *$self->{Pending} = $paragraph ; + my $par = $1 ; + return \$par ; + } + } + return \$paragraph; + } + + # Line Mode + { + my $line ; + my $endl = quotemeta($/); # quote in case $/ contains RE meta chars + while ($self->read($line) > 0 ) { + if ($line =~ s/^(.*?$endl)//s) { + *$self->{Pending} = $line ; + $. = ++ *$self->{LineNo} ; + my $l = $1 ; + return \$l ; + } + } + $. = ++ *$self->{LineNo} if defined($line); + return \$line; + } +} + +sub getline +{ + my $self = shift; + my $current_append = *$self->{AppendOutput} ; + *$self->{AppendOutput} = 1; + my $lineref = $self->_getline(); + *$self->{AppendOutput} = $current_append; + return $$lineref ; +} + +sub getlines +{ + my $self = shift; + croak *$self->{ClassName} . "::getlines: called in scalar context\n" unless wantarray; + my($line, @lines); + push(@lines, $line) while defined($line = $self->getline); + return @lines; +} + +sub READLINE +{ + goto &getlines if wantarray; + goto &getline; +} + +sub getc +{ + my $self = shift; + my $buf; + return $buf if $self->read($buf, 1); + return undef; +} + +sub ungetc +{ + my $self = shift; + *$self->{Pending} = "" unless defined *$self->{Pending} ; + *$self->{Pending} = $_[0] . *$self->{Pending} ; +} + + +sub trailingData +{ + my $self = shift ; + return \"" if ! defined *$self->{Trailing} ; + return \*$self->{Trailing} ; +} + +sub inflateSync +{ + my $self = shift ; + + # inflateSync is a no-op in Plain mode + return 1 + if *$self->{Plain} ; + + return 0 if *$self->{Closed} ; + #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; + return 0 if ! length *$self->{Pending} && *$self->{EndStream} ; + + # Disable CRC check + *$self->{Strict} = 0 ; + + my $status ; + while (1) + { + my $temp_buf ; + + if (length *$self->{Pending} ) + { + $temp_buf = *$self->{Pending} ; + *$self->{Pending} = ''; + } + else + { + $status = $self->smartRead(\$temp_buf, *$self->{BlockSize}) ; + return $self->saveErrorString(0, "Error Reading Data") + if $status < 0 ; + + if ($status == 0 ) { + *$self->{EndStream} = 1 ; + return $self->saveErrorString(0, "unexpected end of file", Z_DATA_ERROR); + } + } + + $status = *$self->{Inflate}->inflateSync($temp_buf) ; + + if ($status == Z_OK) + { + *$self->{Pending} .= $temp_buf ; + return 1 ; + } + + last unless $status = Z_DATA_ERROR ; + } + + return 0; +} + +sub eof +{ + my $self = shift ; + + return (*$self->{Closed} || + (!length *$self->{Pending} + && ( $self->smartEof() || *$self->{EndStream}))) ; +} + +sub tell +{ + my $self = shift ; + + my $in ; + if (*$self->{Plain}) { + $in = *$self->{PlainBytesRead} ; + } + else { + $in = *$self->{TotalInflatedBytesRead} ; + } + + my $pending = length *$self->{Pending} ; + + return 0 if $pending > $in ; + return $in - $pending ; +} + +sub close +{ + # todo - what to do if close is called before the end of the gzip file + # do we remember any trailing data? + my $self = shift ; + + return 1 if *$self->{Closed} ; + + untie *$self + if $] >= 5.008 ; + + my $status = 1 ; + + if (defined *$self->{FH}) { + if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { + #if ( *$self->{AutoClose}) { + $! = 0 ; + $status = *$self->{FH}->close(); + return $self->saveErrorString(0, $!, $!) + if !*$self->{InNew} && $self->saveStatus($!) != 0 ; + } + delete *$self->{FH} ; + $! = 0 ; + } + *$self->{Closed} = 1 ; + + return 1; +} + +sub DESTROY +{ + my $self = shift ; + $self->close() ; +} + +sub seek +{ + my $self = shift ; + my $position = shift; + my $whence = shift ; + + my $here = $self->tell() ; + my $target = 0 ; + + + if ($whence == SEEK_SET) { + $target = $position ; + } + elsif ($whence == SEEK_CUR) { + $target = $here + $position ; + } + elsif ($whence == SEEK_END) { + $target = $position ; + croak *$self->{ClassName} . "::seek: SEEK_END not allowed" ; + } + else { + croak *$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter"; + } + + # short circuit if seeking to current offset + return 1 if $target == $here ; + + # Outlaw any attempt to seek backwards + croak *$self->{ClassName} ."::seek: cannot seek backwards" + if $target < $here ; + + # Walk the file to the new offset + my $offset = $target - $here ; + + my $buffer ; + $self->read($buffer, $offset) == $offset + or return 0 ; + + return 1 ; +} + +sub fileno +{ + my $self = shift ; + return defined *$self->{FH} + ? fileno *$self->{FH} + : undef ; +} + +sub binmode +{ + 1; +# my $self = shift ; +# return defined *$self->{FH} +# ? binmode *$self->{FH} +# : 1 ; +} + +*BINMODE = \&binmode; +*SEEK = \&seek; +*READ = \&read; +*sysread = \&read; +*TELL = \&tell; +*EOF = \&eof; + +*FILENO = \&fileno; +*CLOSE = \&close; + +sub _notAvailable +{ + my $name = shift ; + #return sub { croak "$name Not Available" ; } ; + return sub { croak "$name Not Available: File opened only for intput" ; } ; +} + + +*print = _notAvailable('print'); +*PRINT = _notAvailable('print'); +*printf = _notAvailable('printf'); +*PRINTF = _notAvailable('printf'); +*write = _notAvailable('write'); +*WRITE = _notAvailable('write'); + +#*sysread = \&read; +#*syswrite = \&_notAvailable; + +#package IO::_infScan ; +# +#*_raw_read = \&IO::BaseInflate::_raw_read ; +#*smartRead = \&IO::BaseInflate::smartRead ; +#*smartWrite = \&IO::BaseInflate::smartWrite ; +#*smartSeek = \&IO::BaseInflate::smartSeek ; + +sub scan +{ + my $self = shift ; + + return 1 if *$self->{Closed} ; + return 1 if !length *$self->{Pending} && *$self->{EndStream} ; + + my $buffer = '' ; + my $len = 0; + + $len = $self->_raw_read(\$buffer, 1) + while ! *$self->{EndStream} && $len >= 0 ; + + #return $len if $len < 0 ? $len : 0 ; + return $len < 0 ? 0 : 1 ; +} + +sub zap +{ + my $self = shift ; + + my $headerLength = *$self->{Info}{HeaderLength}; + my $block_offset = $headerLength + *$self->{Inflate}->getLastBlockOffset(); + $_[0] = $headerLength + *$self->{Inflate}->getEndOffset(); + #printf "# End $_[0], headerlen $headerLength \n";; + + #printf "# block_offset $block_offset %x\n", $block_offset; + my $byte ; + ( $self->smartSeek($block_offset) && + $self->smartRead(\$byte, 1) ) + or return $self->saveErrorString(0, $!, $!); + + #printf "#byte is %x\n", unpack('C*',$byte); + *$self->{Inflate}->resetLastBlockByte($byte); + #printf "#to byte is %x\n", unpack('C*',$byte); + + ( $self->smartSeek($block_offset) && + $self->smartWrite($byte) ) + or return $self->saveErrorString(0, $!, $!); + + #$self->smartSeek($end_offset, 1); + + return 1 ; +} + +sub createDeflate +{ + my $self = shift ; + my ($status, $def) = *$self->{Inflate}->createDeflateStream( + -AppendOutput => 1, + -WindowBits => - MAX_WBITS, + -CRC32 => *$self->{Type} eq 'rfc1952' + || *$self->{Type} eq 'zip', + -ADLER32 => *$self->{Type} eq 'rfc1950', + ); + + return wantarray ? ($status, $def) : $def ; +} + + +package IO::Uncompress::Gunzip ; + +1 ; +__END__ + + +=head1 NAME + +IO::Uncompress::Gunzip - Perl interface to read RFC 1952 files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + my $status = gunzip $input => $output [,OPTS] + or die "gunzip failed: $GunzipError\n"; + + my $z = new IO::Uncompress::Gunzip $input [OPTS] + or die "gunzip failed: $GunzipError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $status = $z->inflateSync() + $z->trailingData() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $GunzipError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + + +B<WARNING -- This is a Beta release>. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + + + +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC 1952. + +For writing RFC 1952 files/buffers, see the companion module +IO::Compress::Gzip. + + + +=head1 Functional Interface + +A top-level function, C<gunzip>, is provided to carry out "one-shot" +uncompression between buffers and/or files. For finer control over the uncompression process, see the L</"OO Interface"> section. + + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + gunzip $input => $output [,OPTS] + or die "gunzip failed: $GunzipError\n"; + + gunzip \%hash [,OPTS] + or die "gunzip failed: $GunzipError\n"; + +The functional interface needs Perl5.005 or better. + + +=head2 gunzip $input => $output [, OPTS] + +If the first parameter is not a hash reference C<gunzip> expects +at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, the input data will be read from each +element of the array in turn. The action taken by C<gunzip> with +each element of the array will depend on the type of data stored +in it. You can mix and match any of the types defined in this list, +excluding other array or hash references. +The complete array will be walked to ensure that it only +contains valid data types before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<gunzip> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a filename. +This file will be opened for writing and the uncompressed data will be +written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data will +be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be stored +in C<$$output>. + + +=item A Hash Reference + +If C<$output> is a hash reference, the uncompressed data will be written +to C<$output{$input}> as a scalar reference. + +When C<$output> is a hash reference, C<$input> must be either a filename or +list of filenames. Anything else is an error. + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be pushed +onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<gunzip> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 gunzip \%hash [, OPTS] + +If the first parameter is a hash reference, C<\%hash>, this will be used to +define both the source of compressed data and to control where the +uncompressed data is output. Each key/value pair in the hash defines a +mapping between an input filename, stored in the key, and an output +file/buffer, stored in the value. Although the input can only be a filename, +there is more flexibility to control the destination of the uncompressed +data. This is determined by the type of the value. Valid types are + +=over 5 + +=item undef + +If the value is C<undef> the uncompressed data will be written to the +value as a scalar reference. + +=item A filename + +If the value is a simple scalar, it is assumed to be a filename. This file will +be opened for writing and the uncompressed data will be written to it. + +=item A filehandle + +If the value is a filehandle, the uncompressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If the value is a scalar reference, the uncompressed data will be stored +in the buffer that is referenced by the scalar. + + +=item A Hash Reference + +If the value is a hash reference, the uncompressed data will be written +to C<$hash{$input}> as a scalar reference. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be pushed +onto the array. + +=back + +Any other type is a error. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the uncompressed input files/buffers will all be stored in +C<$output> as a single uncompressed stream. + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<gunzip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item AutoClose =E<gt> 0|1 + +This option applies to any input or output data streams to C<gunzip> +that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<gunzip> has +completed. + +This parameter defaults to 0. + + + +=item -Append =E<gt> 0|1 + +TODO + + + +=back + + + + +=head2 Examples + +To read the contents of the file C<file1.txt.gz> and write the +compressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + my $input = "file1.txt.gz"; + my $output = "file1.txt"; + gunzip $input => $output + or die "gunzip failed: $GunzipError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.gz" + or die "Cannot open 'file1.txt.gz': $!\n" ; + my $buffer ; + gunzip $input => \$buffer + or die "gunzip failed: $GunzipError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.gz" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + gunzip '</my/home/*.txt.gz>' => '</my/home/#1.txt>' + or die "gunzip failed: $GunzipError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + for my $input ( glob "/my/home/*.txt.gz" ) + { + my $output = $input; + $output =~ s/.gz// ; + gunzip $input => $output + or die "Error compressing '$input': $GunzipError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::Gunzip is shown below + + + my $z = new IO::Uncompress::Gunzip $input [OPTS] + or die "IO::Uncompress::Gunzip failed: $GunzipError\n"; + +Returns an C<IO::Uncompress::Gunzip> object on success and undef on failure. +The variable C<$GunzipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::Gunzip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with C<$z>. +For example, to read a line from a compressed file/buffer you can use either +of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item -AutoClose =E<gt> 0|1 + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::Gunzip object is +destroyed. + +This parameter defaults to 0. + +=item -MultiStream =E<gt> 0|1 + + + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + + + +=item -Prime =E<gt> $string + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the case, +the uncompression can be I<primed> with these bytes using this option. + +=item -Transparent =E<gt> 0|1 + +If this option is set and the input file or buffer is not compressed data, +the module will allow reading of it anyway. + +This option defaults to 1. + +=item -BlockSize =E<gt> $num + +When reading the compressed input data, IO::Uncompress::Gunzip will read it in blocks +of C<$num> bytes. + +This option defaults to 4096. + +=item -InputLength =E<gt> $size + +When present this option will limit the number of compressed bytes read from +the input file/buffer to C<$size>. This option can be used in the situation +where there is useful data directly after the compressed data stream and you +know beforehand the exact length of the compressed data stream. + +This option is mostly used when reading from a filehandle, in which case the +file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item -Append =E<gt> 0|1 + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter of +the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method will be +overwritten by the uncompressed data. + +Defaults to 0. + +=item -Strict =E<gt> 0|1 + + + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are carried +out, when Strict is off they are not. + +The default for this option is off. + + + + + + + + + +=over 5 + +=item 1 + +If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the +header must match the crc16 value of the gzip header actually read. + +=item 2 + +If the gzip header contains a name field (FNAME) it consists solely of ISO +8859-1 characters. + +=item 3 + +If the gzip header contains a comment field (FCOMMENT) it consists solely of +ISO 8859-1 characters plus line-feed. + +=item 4 + +If the gzip FEXTRA header field is present it must conform to the sub-field +structure as defined in RFC1952. + +=item 5 + +The CRC32 and ISIZE trailer fields must be present. + +=item 6 + +The value of the CRC32 field read must match the crc32 value of the +uncompressed data actually contained in the gzip file. + +=item 7 + +The value of the ISIZE fields read must match the length of the uncompressed +data actually read from the file. + +=back + + + + + + +=item -ParseExtra =E<gt> 0|1 + +If the gzip FEXTRA header field is present and this option is set, it will +force the module to check that it conforms to the sub-field structure as +defined in RFC1952. + +If the C<Strict> is on it will automatically enable this option. + +Defaults to 0. + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is set +in the constructor, the uncompressed data will be appended to the C<$buffer> +parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or +a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the previous +one, is that this one will attempt to return I<exactly> C<$length> bytes. The +only circumstances that this function will not is if end-of-file or an IO error +is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or +a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> +(or C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Both paragraph mode and file +slurp mode are supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo() + +TODO + + + + + +This method returns a hash reference that contains the contents of each of the +header fields defined in RFC1952. + + + + + + +=over 5 + +=item Comment + +The contents of the Comment header field, if present. If no comment is present, +the value will be undef. Note this is different from a zero length comment, +which will return an empty string. + +=back + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file, this method will return +the underlying filehandle. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::Gunzip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::Gunzip +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::Gunzip at present. + +=over 5 + +=item :all + +Imports C<gunzip> and C<$GunzipError>. +Same as doing this + + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::AnyInflate> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for the gzip program is F<http://www.gzip.org>. + +=head1 AUTHOR + +The I<IO::Uncompress::Gunzip> module was written by Paul Marquess, +F<pmqs@cpan.org>. The latest copy of the module can be +found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>. + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005 Paul Marquess. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + diff --git a/ext/Compress/Zlib/lib/IO/Uncompress/Inflate.pm b/ext/Compress/Zlib/lib/IO/Uncompress/Inflate.pm new file mode 100644 index 0000000000..656b78a1b5 --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Uncompress/Inflate.pm @@ -0,0 +1,808 @@ +package IO::Uncompress::Inflate ; +# for RFC1950 + +use strict ; +use warnings; +use IO::Uncompress::Gunzip ; + + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); + +$VERSION = '2.000_05'; +$InflateError = ''; + +@ISA = qw( Exporter IO::BaseInflate ); +@EXPORT_OK = qw( $InflateError inflate ) ; +%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + +sub new +{ + my $pkg = shift ; + return IO::BaseInflate::new($pkg, 'rfc1950', undef, \$InflateError, 0, @_); +} + +sub inflate +{ + return IO::BaseInflate::_inf(__PACKAGE__, 'rfc1950', \$InflateError, @_); +} + +1 ; + +__END__ + + +=head1 NAME + +IO::Uncompress::Inflate - Perl interface to read RFC 1950 files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + my $status = inflate $input => $output [,OPTS] + or die "inflate failed: $InflateError\n"; + + my $z = new IO::Uncompress::Inflate $input [OPTS] + or die "inflate failed: $InflateError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $status = $z->inflateSync() + $z->trailingData() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $InflateError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + + +B<WARNING -- This is a Beta release>. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + + + +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC 1950. + +For writing RFC 1950 files/buffers, see the companion module +IO::Compress::Deflate. + + + +=head1 Functional Interface + +A top-level function, C<inflate>, is provided to carry out "one-shot" +uncompression between buffers and/or files. For finer control over the uncompression process, see the L</"OO Interface"> section. + + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + inflate $input => $output [,OPTS] + or die "inflate failed: $InflateError\n"; + + inflate \%hash [,OPTS] + or die "inflate failed: $InflateError\n"; + +The functional interface needs Perl5.005 or better. + + +=head2 inflate $input => $output [, OPTS] + +If the first parameter is not a hash reference C<inflate> expects +at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, the input data will be read from each +element of the array in turn. The action taken by C<inflate> with +each element of the array will depend on the type of data stored +in it. You can mix and match any of the types defined in this list, +excluding other array or hash references. +The complete array will be walked to ensure that it only +contains valid data types before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<inflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a filename. +This file will be opened for writing and the uncompressed data will be +written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data will +be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be stored +in C<$$output>. + + +=item A Hash Reference + +If C<$output> is a hash reference, the uncompressed data will be written +to C<$output{$input}> as a scalar reference. + +When C<$output> is a hash reference, C<$input> must be either a filename or +list of filenames. Anything else is an error. + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be pushed +onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<inflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 inflate \%hash [, OPTS] + +If the first parameter is a hash reference, C<\%hash>, this will be used to +define both the source of compressed data and to control where the +uncompressed data is output. Each key/value pair in the hash defines a +mapping between an input filename, stored in the key, and an output +file/buffer, stored in the value. Although the input can only be a filename, +there is more flexibility to control the destination of the uncompressed +data. This is determined by the type of the value. Valid types are + +=over 5 + +=item undef + +If the value is C<undef> the uncompressed data will be written to the +value as a scalar reference. + +=item A filename + +If the value is a simple scalar, it is assumed to be a filename. This file will +be opened for writing and the uncompressed data will be written to it. + +=item A filehandle + +If the value is a filehandle, the uncompressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If the value is a scalar reference, the uncompressed data will be stored +in the buffer that is referenced by the scalar. + + +=item A Hash Reference + +If the value is a hash reference, the uncompressed data will be written +to C<$hash{$input}> as a scalar reference. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be pushed +onto the array. + +=back + +Any other type is a error. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the uncompressed input files/buffers will all be stored in +C<$output> as a single uncompressed stream. + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<inflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item AutoClose =E<gt> 0|1 + +This option applies to any input or output data streams to C<inflate> +that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<inflate> has +completed. + +This parameter defaults to 0. + + + +=item -Append =E<gt> 0|1 + +TODO + + + +=back + + + + +=head2 Examples + +To read the contents of the file C<file1.txt.1950> and write the +compressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + my $input = "file1.txt.1950"; + my $output = "file1.txt"; + inflate $input => $output + or die "inflate failed: $InflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.1950" + or die "Cannot open 'file1.txt.1950': $!\n" ; + my $buffer ; + inflate $input => \$buffer + or die "inflate failed: $InflateError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.1950" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + inflate '</my/home/*.txt.1950>' => '</my/home/#1.txt>' + or die "inflate failed: $InflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + for my $input ( glob "/my/home/*.txt.1950" ) + { + my $output = $input; + $output =~ s/.1950// ; + inflate $input => $output + or die "Error compressing '$input': $InflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::Inflate is shown below + + + my $z = new IO::Uncompress::Inflate $input [OPTS] + or die "IO::Uncompress::Inflate failed: $InflateError\n"; + +Returns an C<IO::Uncompress::Inflate> object on success and undef on failure. +The variable C<$InflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::Inflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with C<$z>. +For example, to read a line from a compressed file/buffer you can use either +of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item -AutoClose =E<gt> 0|1 + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::Inflate object is +destroyed. + +This parameter defaults to 0. + +=item -MultiStream =E<gt> 0|1 + + + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + + + +=item -Prime =E<gt> $string + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the case, +the uncompression can be I<primed> with these bytes using this option. + +=item -Transparent =E<gt> 0|1 + +If this option is set and the input file or buffer is not compressed data, +the module will allow reading of it anyway. + +This option defaults to 1. + +=item -BlockSize =E<gt> $num + +When reading the compressed input data, IO::Uncompress::Inflate will read it in blocks +of C<$num> bytes. + +This option defaults to 4096. + +=item -InputLength =E<gt> $size + +When present this option will limit the number of compressed bytes read from +the input file/buffer to C<$size>. This option can be used in the situation +where there is useful data directly after the compressed data stream and you +know beforehand the exact length of the compressed data stream. + +This option is mostly used when reading from a filehandle, in which case the +file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item -Append =E<gt> 0|1 + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter of +the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method will be +overwritten by the uncompressed data. + +Defaults to 0. + +=item -Strict =E<gt> 0|1 + + + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are carried +out, when Strict is off they are not. + +The default for this option is off. + + + + + +=over 5 + +=item 1 + +The ADLER32 checksum field must be present. + +=item 2 + +The value of the ADLER32 field read must match the adler32 value of the +uncompressed data actually contained in the file. + +=back + + + + + + + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is set +in the constructor, the uncompressed data will be appended to the C<$buffer> +parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or +a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the previous +one, is that this one will attempt to return I<exactly> C<$length> bytes. The +only circumstances that this function will not is if end-of-file or an IO error +is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or +a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> +(or C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Both paragraph mode and file +slurp mode are supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo() + +TODO + + + + + +This method returns a hash reference that contains the contents of each of the +header fields defined in RFC1950. + + + + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file, this method will return +the underlying filehandle. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::Inflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::Inflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::Inflate at present. + +=over 5 + +=item :all + +Imports C<inflate> and C<$InflateError>. +Same as doing this + + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::AnyInflate> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for the gzip program is F<http://www.gzip.org>. + +=head1 AUTHOR + +The I<IO::Uncompress::Inflate> module was written by Paul Marquess, +F<pmqs@cpan.org>. The latest copy of the module can be +found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>. + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005 Paul Marquess. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + diff --git a/ext/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm b/ext/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm new file mode 100644 index 0000000000..45cad1a5dc --- /dev/null +++ b/ext/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm @@ -0,0 +1,776 @@ +package IO::Uncompress::RawInflate ; +# for RFC1951 + +use strict ; +use warnings; +use IO::Uncompress::Gunzip; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $RawInflateError); + +$VERSION = '2.000_05'; +$RawInflateError = ''; + +@ISA = qw(Exporter IO::BaseInflate); +@EXPORT_OK = qw( $RawInflateError rawinflate ) ; +%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + + + +sub new +{ + my $pkg = shift ; + return IO::BaseInflate::new($pkg, 'rfc1951', undef, \$RawInflateError, 0, @_); +} + +sub rawinflate +{ + return IO::BaseInflate::_inf(__PACKAGE__, 'rfc1951', \$RawInflateError, @_); +} + +1; + +__END__ + + +=head1 NAME + +IO::Uncompress::RawInflate - Perl interface to read RFC 1951 files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + my $status = rawinflate $input => $output [,OPTS] + or die "rawinflate failed: $RawInflateError\n"; + + my $z = new IO::Uncompress::RawInflate $input [OPTS] + or die "rawinflate failed: $RawInflateError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $status = $z->inflateSync() + $z->trailingData() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $RawInflateError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + + +B<WARNING -- This is a Beta release>. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + + + +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC 1951. + +For writing RFC 1951 files/buffers, see the companion module +IO::Compress::RawDeflate. + + + +=head1 Functional Interface + +A top-level function, C<rawinflate>, is provided to carry out "one-shot" +uncompression between buffers and/or files. For finer control over the uncompression process, see the L</"OO Interface"> section. + + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + rawinflate $input => $output [,OPTS] + or die "rawinflate failed: $RawInflateError\n"; + + rawinflate \%hash [,OPTS] + or die "rawinflate failed: $RawInflateError\n"; + +The functional interface needs Perl5.005 or better. + + +=head2 rawinflate $input => $output [, OPTS] + +If the first parameter is not a hash reference C<rawinflate> expects +at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, the input data will be read from each +element of the array in turn. The action taken by C<rawinflate> with +each element of the array will depend on the type of data stored +in it. You can mix and match any of the types defined in this list, +excluding other array or hash references. +The complete array will be walked to ensure that it only +contains valid data types before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C<rawinflate> will assume that it is an I<input fileglob string>. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a filename. +This file will be opened for writing and the uncompressed data will be +written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data will +be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be stored +in C<$$output>. + + +=item A Hash Reference + +If C<$output> is a hash reference, the uncompressed data will be written +to C<$output{$input}> as a scalar reference. + +When C<$output> is a hash reference, C<$input> must be either a filename or +list of filenames. Anything else is an error. + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be pushed +onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C<rawinflate> will assume that it is an I<output fileglob string>. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 rawinflate \%hash [, OPTS] + +If the first parameter is a hash reference, C<\%hash>, this will be used to +define both the source of compressed data and to control where the +uncompressed data is output. Each key/value pair in the hash defines a +mapping between an input filename, stored in the key, and an output +file/buffer, stored in the value. Although the input can only be a filename, +there is more flexibility to control the destination of the uncompressed +data. This is determined by the type of the value. Valid types are + +=over 5 + +=item undef + +If the value is C<undef> the uncompressed data will be written to the +value as a scalar reference. + +=item A filename + +If the value is a simple scalar, it is assumed to be a filename. This file will +be opened for writing and the uncompressed data will be written to it. + +=item A filehandle + +If the value is a filehandle, the uncompressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If the value is a scalar reference, the uncompressed data will be stored +in the buffer that is referenced by the scalar. + + +=item A Hash Reference + +If the value is a hash reference, the uncompressed data will be written +to C<$hash{$input}> as a scalar reference. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be pushed +onto the array. + +=back + +Any other type is a error. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the uncompressed input files/buffers will all be stored in +C<$output> as a single uncompressed stream. + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<rawinflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item AutoClose =E<gt> 0|1 + +This option applies to any input or output data streams to C<rawinflate> +that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<rawinflate> has +completed. + +This parameter defaults to 0. + + + +=item -Append =E<gt> 0|1 + +TODO + + + +=back + + + + +=head2 Examples + +To read the contents of the file C<file1.txt.1951> and write the +compressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + my $input = "file1.txt.1951"; + my $output = "file1.txt"; + rawinflate $input => $output + or die "rawinflate failed: $RawInflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.1951" + or die "Cannot open 'file1.txt.1951': $!\n" ; + my $buffer ; + rawinflate $input => \$buffer + or die "rawinflate failed: $RawInflateError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.1951" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + rawinflate '</my/home/*.txt.1951>' => '</my/home/#1.txt>' + or die "rawinflate failed: $RawInflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + for my $input ( glob "/my/home/*.txt.1951" ) + { + my $output = $input; + $output =~ s/.1951// ; + rawinflate $input => $output + or die "Error compressing '$input': $RawInflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::RawInflate is shown below + + + my $z = new IO::Uncompress::RawInflate $input [OPTS] + or die "IO::Uncompress::RawInflate failed: $RawInflateError\n"; + +Returns an C<IO::Uncompress::RawInflate> object on success and undef on failure. +The variable C<$RawInflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::RawInflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with C<$z>. +For example, to read a line from a compressed file/buffer you can use either +of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item -AutoClose =E<gt> 0|1 + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::RawInflate object is +destroyed. + +This parameter defaults to 0. + +=item -MultiStream =E<gt> 0|1 + + + +This option is a no-op. + + + +=item -Prime =E<gt> $string + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the case, +the uncompression can be I<primed> with these bytes using this option. + +=item -Transparent =E<gt> 0|1 + +If this option is set and the input file or buffer is not compressed data, +the module will allow reading of it anyway. + +This option defaults to 1. + +=item -BlockSize =E<gt> $num + +When reading the compressed input data, IO::Uncompress::RawInflate will read it in blocks +of C<$num> bytes. + +This option defaults to 4096. + +=item -InputLength =E<gt> $size + +When present this option will limit the number of compressed bytes read from +the input file/buffer to C<$size>. This option can be used in the situation +where there is useful data directly after the compressed data stream and you +know beforehand the exact length of the compressed data stream. + +This option is mostly used when reading from a filehandle, in which case the +file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item -Append =E<gt> 0|1 + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter of +the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method will be +overwritten by the uncompressed data. + +Defaults to 0. + +=item -Strict =E<gt> 0|1 + + + +This option is a no-op. + + + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is set +in the constructor, the uncompressed data will be appended to the C<$buffer> +parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or +a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the previous +one, is that this one will attempt to return I<exactly> C<$length> bytes. The +only circumstances that this function will not is if end-of-file or an IO error +is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or +a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> +(or C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Both paragraph mode and file +slurp mode are supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo() + +TODO + + + + + + + + + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file, this method will return +the underlying filehandle. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::RawInflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::RawInflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::RawInflate at present. + +=over 5 + +=item :all + +Imports C<rawinflate> and C<$RawInflateError>. +Same as doing this + + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::AnyInflate> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for the gzip program is F<http://www.gzip.org>. + +=head1 AUTHOR + +The I<IO::Uncompress::RawInflate> module was written by Paul Marquess, +F<pmqs@cpan.org>. The latest copy of the module can be +found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>. + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005 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/pod/FAQ.pod b/ext/Compress/Zlib/pod/FAQ.pod new file mode 100644 index 0000000000..9fb270230d --- /dev/null +++ b/ext/Compress/Zlib/pod/FAQ.pod @@ -0,0 +1,198 @@ + +=head1 NAME + +Compress::Zlib::FAQ -- Frequently Asked Questions about Compress::Zlib + +=head1 DESCRIPTION + +Common questions answered. + + + +=head2 Compatibility with Unix compress/uncompress. + +Although C<Compress::Zlib> has a pair of functions called C<compress> +and C<uncompress>, they are I<not> the same as the Unix programs of the +same name. The C<Compress::Zlib> library is not compatible with Unix +C<compress>. + +If you have the C<uncompress> program available, you can use this to +read compressed files + + open F, "uncompress -c $filename |"; + while (<F>) + { + ... + +If you have the C<gunzip> program available, you can use this to read +compressed files + + open F, "gunzip -c $filename |"; + while (<F>) + { + ... + +and this to write compress files if you have the C<compress> program +available + + open F, "| compress -c $filename "; + print F "data"; + ... + close F ; + +=head2 Accessing .tar.Z files + +The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via +the C<IO::Zlib> module) to access tar files that have been compressed +with C<gzip>. Unfortunately tar files compressed with the Unix C<compress> +utility cannot be read by C<Compress::Zlib> and so cannot be directly +accesses by C<Archive::Tar>. + +If the C<uncompress> or C<gunzip> programs are available, you can use +one of these workarounds to read C<.tar.Z> files from C<Archive::Tar> + +Firstly with C<uncompress> + + use strict; + use warnings; + use Archive::Tar; + + open F, "uncompress -c $filename |"; + my $tar = Archive::Tar->new(*F); + ... + +and this with C<gunzip> + + use strict; + use warnings; + use Archive::Tar; + + open F, "gunzip -c $filename |"; + my $tar = Archive::Tar->new(*F); + ... + +Similarly, if the C<compress> program is available, you can use this to +write a C<.tar.Z> file + + use strict; + use warnings; + use Archive::Tar; + use IO::File; + + my $fh = new IO::File "| compress -c >$filename"; + my $tar = Archive::Tar->new(); + ... + $tar->write($fh); + $fh->close ; + + +=head2 Accessing Zip Files + +Although it is possible (with some effort on your part) to use this +module to access .zip files, there is a module on CPAN that will do all +the hard work for you. Check out the C<Archive::Zip> module on CPAN at + + http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz + +Assuming you don't want to use this module to access zip files there +are a number of undocumented features in the zlib library you need to +be aware of. + +=over 5 + +=item 1. + +When calling B<inflateInit> or B<deflateInit> the B<WindowBits> parameter +must be set to C<-MAX_WBITS>. This disables the creation of the zlib +header. + +=item 2. + +The zlib function B<inflate>, and so the B<inflate> method supplied in +this module, assume that there is at least one trailing byte after the +compressed data stream. Normally this isn't a problem because both +the gzip and zip file formats will guarantee that there is data directly +after the compressed data stream. + +=back + + + + + + + + + + + + +=head2 Zlib Library Version Support + +By default C<Compress::Zlib> will build with a private copy of version 1.2.3 of the zlib library. (See the F<README> file for details of how +to override this behavior) + +If you decide to use a different version of the zlib library, you need to be +aware of the following issues + +=over 5 + +=item * + +First off, you must have zlib 1.0.5 or better. + +=item * + +You need to have zlib 1.2.1 or better if you want to use the C<-Merge> option +with C<IO::Compress::Gzip>, C<IO::Compress::Deflate> and C<IO::Compress::RawDeflate>. + + + +=back + + + + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::AnyInflate> + +L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Tar|Archive::Zip>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for the gzip program is F<http://www.gzip.org>. + +=head1 AUTHOR + +The I<> module was written by Paul Marquess, +F<pmqs@cpan.org>. The latest copy of the module can be +found on CPAN in F<modules/by-module/Compress/Compress-Zlib-x.x.tar.gz>. + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005 Paul Marquess. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + + + diff --git a/ext/Compress/Zlib/ppport.h b/ext/Compress/Zlib/ppport.h new file mode 100644 index 0000000000..a3f80aa3d4 --- /dev/null +++ b/ext/Compress/Zlib/ppport.h @@ -0,0 +1,4805 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.02 + + Automatically created by Devel::PPPort running under + perl 5.009002 on Wed Sep 8 21:34:54 2004. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.02 + +=head1 SYNOPSIS + + perl ppport.h [options] [files] + + --help show short help + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + + --list-provided list provided API + --list-unsupported list unsupported API + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.9.2. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +up to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions that were not present in earlier +versions of Perl, and that can't be provided using a macro, you have +to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions will be marked C<explicit> in the list shown by +C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions, you want either C<static> or global variants. + +For a C<static> function, use: + + #define NEED_function + +For a global function, use: + + #define NEED_function_GLOBAL + +Note that you mustn't have more than one global request for one +function in your project. + + Function Static Request Global Request + ----------------------------------------------------------------------------------------- + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions using the C<DPPP_NAMESPACE> macro. +Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + +=cut + +use strict; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! hints! changes! cplusplus + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +usage() if $opt{help}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $v >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +# Never use C comments in this file!!!!! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +my @files; + +if (@ARGV) { + @files = map { glob $_ } @ARGV; +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /\.(xs|c|h|cc)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob $_ } qw(*.xs *.c *.h *.cc); + } + my %filter = map { /(.*)\.xs$/ ? ("$1.c" => 1) : () } @files; + @files = grep { !/\b\Q$ppport\E$/i && !exists $filter{$_} } @files; +} + +unless (@files) { + die "No input files given!\n"; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +AvFILLp|5.004050||p +AvFILL||| +CLASS|||n +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002||p +Copy||| +CvPADLIST||| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvSV||| +Gv_AMupdate||| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeVAL||5.004000| +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LVRET||| +MARK||| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002||p +Move||| +NEWSV||| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newc||| +Newz||| +New||| +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERL_BCDVERSION|5.009002||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_INT_MAX|5.004000||p +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.007002||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.007002||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.007002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.007002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SUBVERSION|5.006000||p +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_DECL|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||n +PL_Sv|5.005000||p +PL_compiling|5.004050||p +PL_copline|5.005000||p +PL_curcop|5.004050||p +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_last_in_gv|||n +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofs_sv|||n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rsfp_filters|5.004050||p +PL_rsfp|5.004050||p +PL_rs|||n +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Poison|5.008000||p +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +ST||| +SVt_IV||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVHV||| +SVt_PVMG||| +SVt_PV||| +Safefree||| +Slab_Alloc||| +Slab_Free||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN||| +SvLOCK||5.007003| +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX||| +SvPV_force_nomg|5.007002||p +SvPV_force||| +SvPV_nolen|5.006000||p +SvPV_nomg|5.007002||p +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec||| +SvREFCNT_inc||| +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV||| +SvSETMAGIC||| +SvSHARE||5.007003| +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK||5.007001| +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +THIS|||n +UNDERBAR|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN||| +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XS||| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_pMY_CXT|5.007003||p +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHX_|5.006000||p +aTHX|5.006000||p +add_data||| +allocmy||| +amagic_call||| +any_dup||| +ao||| +append_elem||| +append_list||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +asIV||| +asUV||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_clear||| +av_delete||5.006000| +av_exists||5.006000| +av_extend||| +av_fake||| +av_fetch||| +av_fill||| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_undef||| +av_unshift||| +ax|||n +bad_type||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_xsutils||| +bytes_from_utf8||5.007001| +bytes_to_utf8||5.006001| +cache_re||| +call_argv|5.006000||p +call_atexit||5.006000| +call_body||| +call_list_body||| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_uni||| +checkcomma||| +checkposixcc||| +cl_and||| +cl_anything||| +cl_init_zero||| +cl_init||| +cl_is_anything||| +cl_or||| +closest_cop||| +convert||| +cop_free||| +cr_textfilter||| +croak_nocontext|||vn +croak|||v +csighandler||5.007001|n +custom_op_desc||5.007003| +custom_op_name||5.007003| +cv_ckproto||| +cv_clone||| +cv_const_sv||5.004000| +cv_dump||| +cv_undef||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dXSARGS||| +dXSI32||| +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +deb||5.007003|v +default_protect|||v +del_he||| +del_sv||| +del_xiv||| +del_xnv||| +del_xpvav||| +del_xpvbm||| +del_xpvcv||| +del_xpvhv||| +del_xpviv||| +del_xpvlv||| +del_xpvmg||| +del_xpvnv||| +del_xpv||| +del_xrv||| +delimcpy||5.004000| +depcom||| +deprecate_old||| +deprecate||| +despatch_signals||5.007001| +die_nocontext|||vn +die_where||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_chop||| +do_close||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_kv||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_oddball||| +do_op_dump||5.006000| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pipe||| +do_pmop_dump||5.006000| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch_body||| +docatch||| +doencodes||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptosub||| +dounwind||| +dowantarray||| +dump_all||5.006000| +dump_eval||5.006000| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs||5.006000| +dump_sub||5.006000| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_eaccess||| +eval_pv|5.006000||p +eval_sv|5.006000||p +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +fd_on_nosuid_fs||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +find_beginning||| +find_byclass||| +find_in_my_stash||| +find_runcv||| +find_rundefsvoffset||5.009002| +find_script||| +find_uninit_var||| +fold_constants||| +forbid_setid||| +force_ident||| +force_list||| +force_next||| +force_version||| +force_word||| +form_nocontext|||vn +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_av|5.006000||p +get_context||5.006000|n +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_hex|5.007003||p +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_autoload4||5.004000| +gv_check||| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpv||| +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_sv||| +gv_init||| +gv_share||| +gv_stashpvn|5.006000||p +gv_stashpv||| +gv_stashsv||| +he_dup||| +hfreeentries||| +hsplit||| +hv_assert||5.009001| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_common||| +hv_fetch_ent||5.004000| +hv_fetch||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.004000| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_ksplit||5.004000| +hv_magic_check||| +hv_magic||| +hv_notallowed||| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_store||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incl_perldb||| +incline||| +incpush||| +ingroup||| +init_argv_symbols||| +init_debugger||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_lexer||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +instr||| +intro_my||| +intuit_method||| +intuit_more||| +invert||| +io_close||| +isALNUM||| +isALPHA||| +isDIGIT||| +isLOWER||| +isSPACE||| +isUPPER||| +is_an_int||| +is_gv_magical||| +is_handle_constructor||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.006000| +is_uni_alnumc||5.006000| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.006000| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_char||5.006000| +is_utf8_cntrl||5.006000| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loc||5.008001| +is_utf8_string||5.006001| +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +keyword||| +leave_scope||| +lex_end||| +lex_start||| +linklist||| +list_assignment||| +listkids||| +list||| +load_module_nocontext|||vn +load_module||5.006000|v +localize||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHu|5.009002||p +magic_clear_all_env||| +magic_clearenv||| +magic_clearpack||| +magic_clearsig||| +magic_dump||5.006000| +magic_existspack||| +magic_freeovrld||| +magic_freeregexp||| +magic_getarylen||| +magic_getdefelem||| +magic_getglob||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_len||| +magic_methcall||| +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setamagic||| +magic_setarylen||| +magic_setbm||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_setfm||| +magic_setglob||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +magicname||| +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +measure_struct||| +memEQ|5.004000||p +memNE|5.004000||p +mem_collxfrm||| +mess_alloc||| +mess_nocontext|||vn +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find||| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +missingterm||| +mode_from_discipline||| +modkids||| +mod||| +more_he||| +more_sv||| +more_xiv||| +more_xnv||| +more_xpvav||| +more_xpvbm||| +more_xpvcv||| +more_xpvhv||| +more_xpviv||| +more_xpvlv||| +more_xpvmg||| +more_xpvnv||| +more_xpv||| +more_xrv||| +moreswitches||| +mul128||| +mulexp10|||n +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_betoh16|||n +my_betoh32|||n +my_betoh64|||n +my_betohi|||n +my_betohl|||n +my_betohs|||n +my_bzero|||n +my_chsize||| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_htobe16|||n +my_htobe32|||n +my_htobe64|||n +my_htobei|||n +my_htobel|||n +my_htobes|||n +my_htole16|||n +my_htole32|||n +my_htole64|||n +my_htolei|||n +my_htolel|||n +my_htoles|||n +my_htonl||| +my_kid||| +my_letoh16|||n +my_letoh32|||n +my_letoh64|||n +my_letohi|||n +my_letohl|||n +my_letohs|||n +my_lstat||| +my_memcmp||5.004000|n +my_memset|||n +my_ntohl||| +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_socketpair||5.007003|n +my_stat||| +my_strftime||5.007002| +my_swabn|||n +my_swap||| +my_unexec||| +my||| +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB|5.006000||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||| +newGVOP||| +newGVREF||| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMYSUB||5.006000| +newNULLLIST||| +newOP||| +newPADOP||5.006000| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.006000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSUB||| +newSVOP||| +newSVREF||| +newSViv||| +newSVnv||| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_share||5.007001| +newSVpvn|5.006000||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newUNOP||| +newWHILEOP||5.004040| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_xiv||| +new_xnv||| +new_xpvav||| +new_xpvbm||| +new_xpvcv||| +new_xpvhv||| +new_xpviv||| +new_xpvlv||| +new_xpvmg||| +new_xpvnv||| +new_xpv||| +new_xrv||| +next_symbol||| +nextargv||| +nextchar||| +ninstr||| +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsCV||| +oopsHV||| +op_clear||| +op_const_sv||| +op_dump||5.006000| +op_free||| +op_null||5.007002| +open_script||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +pack_cat||5.007003| +pack_rec||| +package||| +packlist||5.008001| +pad_add_anon||| +pad_add_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_findlex||| +pad_findmy||| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||| +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||| +pad_undef||| +parse_body||| +parse_unicode_opts||| +path_is_absolute||| +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pmflag||| +pmop_dump||5.006000| +pmruntime||| +pmtrans||| +pop_scope||| +pregcomp||| +pregexec||| +pregfree||| +prepend_elem||| +printf_nocontext|||vn +ptr_table_clear||| +ptr_table_fetch||| +ptr_table_free||| +ptr_table_new||| +ptr_table_split||| +ptr_table_store||| +push_scope||| +put_byte||| +pv_display||5.006000| +pv_uni_display||5.007003| +qerror||| +re_croak2||| +re_dup||| +re_intuit_start||5.006000| +re_intuit_string||5.006000| +realloc||5.007002|n +reentrant_free||| +reentrant_init||| +reentrant_retry|||vn +reentrant_size||| +refkids||| +refto||| +ref||| +reg_node||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.007003| +regclass||| +regcp_set_to||| +regcppop||| +regcppush||| +regcurly||| +regdump||5.005000| +regexec_flags||5.005000| +reghop3||| +reghopmaybe3||| +reghopmaybe||| +reghop||| +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regoptail||| +regpiece||| +regpposixcc||| +regprop||| +regrepeat_hard||| +regrepeat||| +regtail||| +regtry||| +reguni||| +regwhite||| +reg||| +repeatcpy||| +report_evil_fh||| +report_uninit||| +require_errno||| +require_pv||5.006000| +rninstr||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +runops_debug||5.005000| +runops_standard||5.005000| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hek_flags||| +save_helem||5.004050| +save_hints||5.005000| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||| +save_padsv||5.007001| +save_pptr||| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_threadsv||5.005000| +save_vptr||5.006000| +savepvn||| +savepv||| +savesharedpv||5.007003| +savestack_grow_cnt||5.008001| +savestack_grow||| +sawparens||| +scalar_mod_type||| +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.008001| +scan_word||| +scope||| +screaminstr||5.005000| +seed||| +set_context||5.006000|n +set_csh||| +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +setdefout||| +setenv_getix||| +share_hek_flags||| +share_hek||| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace||| +sortsv||5.007003| +ss_dup||| +stack_grow||| +start_glob||| +start_subparse||5.004000| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2nv||| +sv_2pv_flags||5.007002| +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen||| +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff||| +sv_bless||| +sv_cat_decode||5.008001| +sv_catpv_mg|5.006000||p +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.006000||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.006000||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm||| +sv_compile_2op||5.008001| +sv_copypv||5.007003| +sv_dec||| +sv_del_backref||| +sv_derived_from||5.004000| +sv_dump||| +sv_dup||| +sv_eq||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_inc||| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_len_utf8||5.006000| +sv_len||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||5.007003| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u||5.006000| +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags||5.007002| +sv_pvn_force|||p +sv_pvn_nomg|5.007003||p +sv_pvn|5.006000||p +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_release_COW||| +sv_release_IVX||| +sv_replace||| +sv_report_used||| +sv_reset||| +sv_rvweaken||5.006000| +sv_setiv_mg|5.006000||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.006000||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.006000||p +sv_setpvn||| +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.006000||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.006000||p +sv_setuv|5.006000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_mg|5.006000||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.006000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +taint_env||| +taint_proper||| +tmps_grow||5.006000| +toLOWER||| +toUPPER||| +to_byte_substr||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.007003| +to_utf8_lower||5.007003| +to_utf8_substr||| +to_utf8_title||5.007003| +to_utf8_upper||5.007003| +tokeq||| +tokereport||| +too_few_arguments||| +too_many_arguments||| +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +upg_version||5.009000| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf16rev_textfilter||| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_pos_init||| +utf8_mg_pos||| +utf8_to_bytes||5.006001| +utf8_to_uvchr||5.007001| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||5.007001| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||5.007001| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +validate_suid||| +vcall_body||| +vcall_list_body||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vdefault_protect||| +vdie||| +vdocatch_body||| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module||5.006000| +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vparse_body||| +vrun_body||| +vstringify||5.009000| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warner_nocontext|||vn +warner||5.006000|v +warn|||v +watch||| +whichsig||| +write_to_stderr||| +yyerror||| +yylex||| +yyparse||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %depends); +my $replace = 0; +my $hint = ''; + +while (<DATA>) { + if ($hint) { + if (m{^\s*\*\s(.*?)\s*$}) { + $hints{$hint} ||= ''; # suppress warning with older perls + $hints{$hint} .= "$1\n"; + } + else { + $hint = ''; + } + } + $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # temporarily remove C comments from the code + my @ccom; + $c =~ s{ + ( + [^"'/]+ + | + (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+ + | + (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+ + ) + | + (/ (?: + \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / + | + /[^\r\n]* + )) + }{ + defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce"; + }egsx; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/); + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + if (exists $need{$_}) { + $file{needs}{$_} = 'static'; + } + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { + warning("Possibly wrong #define $1 in $filename"); + } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses}}) { + next unless $file{uses}{$func}; # if it's only a dependency + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + elsif (exists $replace{$func}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + else { + diag("Uses $func"); + } + hint($func); + } + + for $func (sort keys %{$file{uses_todo}}) { + warning("Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo})); + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and can_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; + +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub can_use +{ + eval "use @_;"; + return $@ eq ''; +} + +sub rec_depend +{ + my $func = shift; + my %seen; + return () unless exists $depends{$func}; + grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +sub hint +{ + $opt{quiet} and return; + $opt{hints} or return; + my $func = shift; + exists $hints{$func} or return; + $given_hints{$func}++ and return; + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif + +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif + +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_na na +# define PL_no_modify no_modify +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_ppaddr ppaddr +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +/* Replace: 0 */ +#endif + +#ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +#else +# define PERL_UNUSED_DECL +#endif +#ifndef NOOP +# define NOOP (void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR + +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif + +# define NUM2PTR(any,d) (any)(PTRV)(d) +# define PTR2IV(p) INT2PTR(IV,p) +# define PTR2UV(p) INT2PTR(UV,p) +# define PTR2NV(p) NUM2PTR(NV,p) + +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif + +#endif /* !INT2PTR */ + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC) +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#undef STMT_START +#undef STMT_END +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d) +#endif + +#endif +#ifndef Poison +# define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t)) +#endif +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u)) +#endif +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ + +/* Replace perl_eval_pv with eval_pv */ +/* eval_pv depends on eval_sv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5)) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +void +DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))) + start_subparse(), +#elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22)) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +#ifndef START_MY_CXT + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#else /* single interpreter */ + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT_CLONE NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif + +#endif /* START_MY_CXT */ + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvPV_nolen + +/* #if defined(NEED_sv_2pv_nolen) */ +#if 1 +static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +static +#else +extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +#endif + +#ifdef sv_2pv_nolen +# undef sv_2pv_nolen +#endif +#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a) +#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen) + +/* #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) */ +#if 1 + +char * +DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() macro instead of sv_2pv_nolen(). + */ + +/* SvPV_nolen depends on sv_2pv_nolen */ +#define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) + +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0))) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +/* SvPVbyte depends on sv_2pvbyte */ +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif + +/* sv_2pvbyte_nolen depends on sv_2pv_nolen */ +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen sv_2pv_nolen +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ +#ifndef sv_pvn +# define sv_pvn(sv, len) SvPV(sv, len) +#endif + +/* Hint: sv_pvn + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ +#ifndef sv_pvn_force +# define sv_pvn_force(sv, len) SvPV_force(sv, len) +#endif + +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +/* sv_vcatpvf depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_vsetpvf depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +/* sv_vcatpvf_mg depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +/* sv_vsetpvf_mg depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef SvPV_force_nomg +# define SvPV_force_nomg SvPV_force +#endif + +#ifndef SvPV_nomg +# define SvPV_nomg SvPV +#endif + +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif + +/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */ +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif /* PERL_VERSION */ +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +/* grok_number depends on grok_numeric_radix */ + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/ext/Compress/Zlib/t/01version.t b/ext/Compress/Zlib/t/01version.t index ea5b6a0bb4..bdb8a9ad23 100644 --- a/ext/Compress/Zlib/t/01version.t +++ b/ext/Compress/Zlib/t/01version.t @@ -1,34 +1,36 @@ +use lib 't'; use strict ; use warnings ; -use Compress::Zlib ; +use Test::More ; -sub ok -{ - my ($no, $ok) = @_ ; +BEGIN +{ + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - #++ $total ; - #++ $totalBad unless $ok ; + plan tests => 2 + $extra ; - print "ok $no\n" if $ok ; - print "not ok $no\n" unless $ok ; - return $ok; + use_ok('Compress::Zlib', 2) ; } -print "1..1\n" ; - # Check zlib_version and ZLIB_VERSION are the same. + my $zlib_h = ZLIB_VERSION ; my $libz = Compress::Zlib::zlib_version; -ok(1, $zlib_h eq $libz) || -print <<EOM; -# The version of zlib.h does not match the version of libz -# -# You have zlib.h version $zlib_h -# and libz version $libz -# -# You probably have two versions of zlib installed on your system. -# Try removing the one you don't want to use and rebuild. + +is($zlib_h, $libz, "ZLIB_VERSION ($zlib_h) matches Compress::Zlib::zlib_version") + or diag <<EOM; + +The version of zlib.h does not match the version of libz + +You have zlib.h version $zlib_h + and libz version $libz + +You probably have two versions of zlib installed on your system. +Try removing the one you don't want to use and rebuild. EOM diff --git a/ext/Compress/Zlib/t/02zlib.t b/ext/Compress/Zlib/t/02zlib.t index e4802d113f..530e221d27 100644 --- a/ext/Compress/Zlib/t/02zlib.t +++ b/ext/Compress/Zlib/t/02zlib.t @@ -1,34 +1,38 @@ +use lib 't'; +use strict; +use warnings; +use bytes; -use strict ; -use warnings ; +use Test::More ; +use ZlibTestUtils; -use Compress::Zlib ; -sub ok -{ - my ($no, $ok) = @_ ; +BEGIN +{ + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + + my $count = 0 ; + if ($] < 5.005) { + $count = 188 ; + } + elsif ($] >= 5.006) { + $count = 242 ; + } + else { + $count = 200 ; + } - #++ $total ; - #++ $totalBad unless $ok ; + plan tests => $count + $extra; - print "ok $no\n" if $ok ; - print "not ok $no\n" unless $ok ; + use_ok('Compress::Zlib', 2) ; } -sub readFile -{ - my ($filename) = @_ ; - my ($string) = '' ; - - open (F, "<$filename") - or die "Cannot open $filename: $!\n" ; - binmode(F); - while (<F>) - { $string .= $_ } - close F ; - $string ; -} + my $hello = <<EOM ; hello world @@ -37,695 +41,416 @@ EOM my $len = length $hello ; - -print "1..239\n" ; - # Check zlib_version and ZLIB_VERSION are the same. -ok(1, Compress::Zlib::zlib_version eq ZLIB_VERSION) ; - -# gzip tests -#=========== - -my $name = "test.gz" ; -my ($x, $uncomp) ; - -ok(2, my $fil = gzopen($name, "wb")) ; - -ok(3, $gzerrno == 0); - -ok(4, $fil->gzwrite($hello) == $len) ; - -ok(5, ! $fil->gzclose ) ; - -ok(6, $fil = gzopen($name, "rb") ) ; - -ok(7, $gzerrno == 0); - -ok(8, ($x = $fil->gzread($uncomp)) == $len) ; - -ok(9, ! $fil->gzclose ) ; +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; -unlink $name ; - -ok(10, $hello eq $uncomp) ; - -# check that a number can be gzipped -my $number = 7603 ; -my $num_len = 4 ; - -ok(11, $fil = gzopen($name, "wb")) ; - -ok(12, $gzerrno == 0); - -ok(13, $fil->gzwrite($number) == $num_len) ; - -ok(14, $gzerrno == 0); - -ok(15, ! $fil->gzclose ) ; - -ok(16, $gzerrno == 0); +{ + title "Error Cases" ; -ok(17, $fil = gzopen($name, "rb") ) ; + eval { new Compress::Zlib::Deflate(-Level) }; + like $@, mkErr("^Compress::Zlib::Deflate::new: Expected even number of parameters, got 1") ; -ok(18, ($x = $fil->gzread($uncomp)) == $num_len) ; + eval { new Compress::Zlib::Inflate(-Level) }; + like $@, mkErr("^Compress::Zlib::Inflate::new: Expected even number of parameters, got 1"); -ok(19, $gzerrno == 0 || $gzerrno == Z_STREAM_END); + eval { new Compress::Zlib::Deflate(-Joe => 1) }; + like $@, mkErr('^Compress::Zlib::Deflate::new: unknown key value\(s\) Joe'); -ok(20, ! $fil->gzclose ) ; + eval { new Compress::Zlib::Inflate(-Joe => 1) }; + like $@, mkErr('^Compress::Zlib::Inflate::new: unknown key value\(s\) Joe'); -ok(21, $gzerrno == 0); + eval { new Compress::Zlib::Deflate(-Bufsize => 0) }; + like $@, mkErr("^Compress::Zlib::Deflate::new: Bufsize must be >= 1, you specified 0"); -unlink $name ; + eval { new Compress::Zlib::Inflate(-Bufsize => 0) }; + like $@, mkErr("^Compress::Zlib::Inflate::new: Bufsize must be >= 1, you specified 0"); -ok(22, $number == $uncomp) ; -ok(23, $number eq $uncomp) ; + eval { new Compress::Zlib::Deflate(-Bufsize => -1) }; + like $@, mkErr("^Compress::Zlib::Deflate::new: Parameter 'Bufsize' must be an unsigned int, got '-1'"); + eval { new Compress::Zlib::Inflate(-Bufsize => -1) }; + like $@, mkErr("^Compress::Zlib::Inflate::new: Parameter 'Bufsize' must be an unsigned int, got '-1'"); -# now a bigger gzip test + eval { new Compress::Zlib::Deflate(-Bufsize => "xxx") }; + like $@, mkErr("^Compress::Zlib::Deflate::new: Parameter 'Bufsize' must be an unsigned int, got 'xxx'"); -my $text = 'text' ; -my $file = "$text.gz" ; + eval { new Compress::Zlib::Inflate(-Bufsize => "xxx") }; + like $@, mkErr("^Compress::Zlib::Inflate::new: Parameter 'Bufsize' must be an unsigned int, got 'xxx'"); -ok(24, my $f = gzopen($file, "wb")) ; + eval { new Compress::Zlib::Inflate(-Bufsize => 1, 2) }; + like $@, mkErr("^Compress::Zlib::Inflate::new: Expected even number of parameters, got 3"); -# generate a long random string -my $contents = '' ; -foreach (1 .. 5000) - { $contents .= chr int rand 256 } + eval { new Compress::Zlib::Deflate(-Bufsize => 1, 2) }; + like $@, mkErr("^Compress::Zlib::Deflate::new: Expected even number of parameters, got 3"); -$len = length $contents ; +} -ok(25, $f->gzwrite($contents) == $len ) ; +{ -ok(26, ! $f->gzclose ); + title "deflate/inflate - small buffer"; + # ============================== -ok(27, $f = gzopen($file, "rb")) ; + my $hello = "I am a HAL 9000 computer" ; + my @hello = split('', $hello) ; + my ($err, $x, $X, $status); -my $uncompressed ; -ok(28, $f->gzread($uncompressed, $len) == $len) ; - -ok(29, $contents eq $uncompressed) ; - -ok(30, ! $f->gzclose ) ; - -unlink($file) ; - -# gzip - readline tests -# ====================== + ok( ($x, $err) = new Compress::Zlib::Deflate ( -Bufsize => 1 ), "Create deflate object" ); + ok $x, "Compress::Zlib::Deflate ok" ; + cmp_ok $err, '==', Z_OK, "status is Z_OK" ; + + ok ! defined $x->msg() ; + is $x->total_in(), 0, "total_in() == 0" ; + is $x->total_out(), 0, "total_out() == 0" ; -# first create a small gzipped text file -$name = "test.gz" ; -my @text = (<<EOM, <<EOM, <<EOM, <<EOM) ; -this is line 1 -EOM -the second line -EOM -the line after the previous line -EOM -the final line -EOM + $X = "" ; + my $Answer = ''; + foreach (@hello) + { + $status = $x->deflate($_, $X) ; + last unless $status == Z_OK ; + + $Answer .= $X ; + } + + cmp_ok $status, '==', Z_OK, "deflate returned Z_OK" ; + + cmp_ok $x->flush($X), '==', Z_OK, "flush returned Z_OK" ; + $Answer .= $X ; + + ok ! defined $x->msg() ; + is $x->total_in(), length $hello, "total_in ok" ; + is $x->total_out(), length $Answer, "total_out ok" ; + + my @Answer = split('', $Answer) ; + + my $k; + ok(($k, $err) = new Compress::Zlib::Inflate( {-Bufsize => 1}) ); + ok $k, "Compress::Zlib::Inflate ok" ; + cmp_ok $err, '==', Z_OK, "status is Z_OK" ; + + ok ! defined $k->msg(), "No error messages" ; + is $k->total_in(), 0, "total_in() == 0" ; + is $k->total_out(), 0, "total_out() == 0" ; + my $GOT = ''; + my $Z; + $Z = 1 ;#x 2000 ; + foreach (@Answer) + { + $status = $k->inflate($_, $Z) ; + $GOT .= $Z ; + last if $status == Z_STREAM_END or $status != Z_OK ; + + } + + cmp_ok $status, '==', Z_STREAM_END, "Got Z_STREAM_END" ; + is $GOT, $hello, "uncompressed data matches ok" ; + ok ! defined $k->msg(), "No error messages" ; + is $k->total_in(), length $Answer, "total_in ok" ; + is $k->total_out(), length $hello , "total_out ok"; -$text = join("", @text) ; - -ok(31, $fil = gzopen($name, "wb")) ; -ok(32, $fil->gzwrite($text) == length $text) ; -ok(33, ! $fil->gzclose ) ; - -# now try to read it back in -ok(34, $fil = gzopen($name, "rb")) ; -my $aok = 1 ; -my $remember = ''; -my $line = ''; -my $lines = 0 ; -while ($fil->gzreadline($line) > 0) { - ($aok = 0), last - if $line ne $text[$lines] ; - $remember .= $line ; - ++ $lines ; } -ok(35, $aok) ; -ok(36, $remember eq $text) ; -ok(37, $lines == @text) ; -ok(38, ! $fil->gzclose ) ; -unlink($name) ; - -# a text file with a very long line (bigger than the internal buffer) -my $line1 = ("abcdefghijklmnopq" x 2000) . "\n" ; -my $line2 = "second line\n" ; -$text = $line1 . $line2 ; -ok(39, $fil = gzopen($name, "wb")) ; -ok(40, $fil->gzwrite($text) == length $text) ; -ok(41, ! $fil->gzclose ) ; - -# now try to read it back in -ok(42, $fil = gzopen($name, "rb")) ; -my $i = 0 ; -my @got = (); -while ($fil->gzreadline($line) > 0) { - $got[$i] = $line ; - ++ $i ; -} -ok(43, $i == 2) ; -ok(44, $got[0] eq $line1 ) ; -ok(45, $got[1] eq $line2) ; - -ok(46, ! $fil->gzclose ) ; - -unlink $name ; -# a text file which is not termined by an EOL -$line1 = "hello hello, I'm back again\n" ; -$line2 = "there is no end in sight" ; +{ + # deflate/inflate - small buffer with a number + # ============================== -$text = $line1 . $line2 ; -ok(47, $fil = gzopen($name, "wb")) ; -ok(48, $fil->gzwrite($text) == length $text) ; -ok(49, ! $fil->gzclose ) ; + my $hello = 6529 ; + + ok my ($x, $err) = new Compress::Zlib::Deflate ( -Bufsize => 1, -AppendOutput => 1 ) ; + ok $x ; + cmp_ok $err, '==', Z_OK ; + + my $status; + my $Answer = ''; + + cmp_ok $x->deflate($hello, $Answer), '==', Z_OK ; + + cmp_ok $x->flush($Answer), '==', Z_OK ; + + my @Answer = split('', $Answer) ; + + my $k; + ok(($k, $err) = new Compress::Zlib::Inflate( {-Bufsize => 1, -AppendOutput =>1}) ); + ok $k ; + cmp_ok $err, '==', Z_OK ; + + #my $GOT = ''; + my $GOT ; + foreach (@Answer) + { + $status = $k->inflate($_, $GOT) ; + last if $status == Z_STREAM_END or $status != Z_OK ; + + } + + cmp_ok $status, '==', Z_STREAM_END ; + is $GOT, $hello ; -# now try to read it back in -ok(50, $fil = gzopen($name, "rb")) ; -@got = () ; $i = 0 ; -while ($fil->gzreadline($line) > 0) { - $got[$i] = $line ; - ++ $i ; } -ok(51, $i == 2) ; -ok(52, $got[0] eq $line1 ) ; -ok(53, $got[1] eq $line2) ; - -ok(54, ! $fil->gzclose ) ; - -unlink $name ; +{ -# mix gzread and gzreadline < - -# case 1: read a line, then a block. The block is -# smaller than the internal block used by -# gzreadline -$line1 = "hello hello, I'm back again\n" ; -$line2 = "abc" x 200 ; -my $line3 = "def" x 200 ; - -$text = $line1 . $line2 . $line3 ; -ok(55, $fil = gzopen($name, "wb")) ; -ok(56, $fil->gzwrite($text) == length $text) ; -ok(57, ! $fil->gzclose ) ; - -# now try to read it back in -ok(58, $fil = gzopen($name, "rb")) ; -ok(59, $fil->gzreadline($line) > 0) ; -ok(60, $line eq $line1) ; -ok(61, $fil->gzread($line, length $line2) > 0) ; -ok(62, $line eq $line2) ; -ok(63, $fil->gzread($line, length $line3) > 0) ; -ok(64, $line eq $line3) ; -ok(65, ! $fil->gzclose ) ; -unlink $name ; - -# change $/ <<TODO - - - -# compress/uncompress tests -# ========================= - -$hello = "hello mum" ; -my $keep_hello = $hello ; - -my $compr = compress($hello) ; -ok(66, $compr ne "") ; - -my $keep_compr = $compr ; - -my $uncompr = uncompress ($compr) ; - -ok(67, $hello eq $uncompr) ; - -ok(68, $hello eq $keep_hello) ; -ok(69, $compr eq $keep_compr) ; - -# compress a number -$hello = 7890 ; -$keep_hello = $hello ; - -$compr = compress($hello) ; -ok(70, $compr ne "") ; - -$keep_compr = $compr ; - -$uncompr = uncompress ($compr) ; - -ok(71, $hello eq $uncompr) ; - -ok(72, $hello eq $keep_hello) ; -ok(73, $compr eq $keep_compr) ; - -# bigger compress - -$compr = compress ($contents) ; -ok(74, $compr ne "") ; - -$uncompr = uncompress ($compr) ; - -ok(75, $contents eq $uncompr) ; - -# buffer reference - -$compr = compress(\$hello) ; -ok(76, $compr ne "") ; - - -$uncompr = uncompress (\$compr) ; -ok(77, $hello eq $uncompr) ; - -# bad level -$compr = compress($hello, 1000) ; -ok(78, ! defined $compr); +# deflate/inflate options - AppendOutput +# ================================ -# change level -$compr = compress($hello, Z_BEST_COMPRESSION) ; -ok(79, defined $compr); -$uncompr = uncompress (\$compr) ; -ok(80, $hello eq $uncompr) ; + # AppendOutput + # CRC -# deflate/inflate - small buffer -# ============================== + my $hello = "I am a HAL 9000 computer" ; + my @hello = split('', $hello) ; + + ok my ($x, $err) = new Compress::Zlib::Deflate ( {-Bufsize => 1, -AppendOutput =>1} ) ; + ok $x ; + cmp_ok $err, '==', Z_OK ; + + my $status; + my $X; + foreach (@hello) + { + $status = $x->deflate($_, $X) ; + last unless $status == Z_OK ; + } + + cmp_ok $status, '==', Z_OK ; + + cmp_ok $x->flush($X), '==', Z_OK ; + + + my @Answer = split('', $X) ; + + my $k; + ok(($k, $err) = new Compress::Zlib::Inflate( {-Bufsize => 1, -AppendOutput =>1})); + ok $k ; + cmp_ok $err, '==', Z_OK ; + + my $Z; + foreach (@Answer) + { + $status = $k->inflate($_, $Z) ; + last if $status == Z_STREAM_END or $status != Z_OK ; + + } + + cmp_ok $status, '==', Z_STREAM_END ; + is $Z, $hello ; +} -$hello = "I am a HAL 9000 computer" ; -my @hello = split('', $hello) ; -my ($err, $X, $status); - -ok(81, ($x, $err) = deflateInit( {-Bufsize => 1} ) ) ; -ok(82, $x) ; -ok(83, $err == Z_OK) ; -my $Answer = ''; -foreach (@hello) { - ($X, $status) = $x->deflate($_) ; - last unless $status == Z_OK ; - $Answer .= $X ; -} - -ok(84, $status == Z_OK) ; + title "deflate/inflate - larger buffer"; + # ============================== -ok(85, (($X, $status) = $x->flush())[1] == Z_OK ) ; -$Answer .= $X ; - - -my @Answer = split('', $Answer) ; - -my $k; -ok(86, ($k, $err) = inflateInit( {-Bufsize => 1}) ) ; -ok(87, $k) ; -ok(88, $err == Z_OK) ; - -my $GOT = ''; -my $Z; -foreach (@Answer) -{ - ($Z, $status) = $k->inflate($_) ; - $GOT .= $Z ; - last if $status == Z_STREAM_END or $status != Z_OK ; - -} + # generate a long random string + my $contents = '' ; + foreach (1 .. 50000) + { $contents .= chr int rand 255 } + + + ok my ($x, $err) = new Compress::Zlib::Deflate() ; + ok $x ; + cmp_ok $err, '==', Z_OK ; + + my (%X, $Y, %Z, $X, $Z); + #cmp_ok $x->deflate($contents, $X{key}), '==', Z_OK ; + cmp_ok $x->deflate($contents, $X), '==', Z_OK ; + + #$Y = $X{key} ; + $Y = $X ; + + + #cmp_ok $x->flush($X{key}), '==', Z_OK ; + #$Y .= $X{key} ; + cmp_ok $x->flush($X), '==', Z_OK ; + $Y .= $X ; + + -ok(89, $status == Z_STREAM_END) ; -ok(90, $GOT eq $hello ) ; + my $keep = $Y ; + my $k; + ok(($k, $err) = new Compress::Zlib::Inflate() ); + ok $k ; + cmp_ok $err, '==', Z_OK ; + + #cmp_ok $k->inflate($Y, $Z{key}), '==', Z_STREAM_END ; + #ok $contents eq $Z{key} ; + cmp_ok $k->inflate($Y, $Z), '==', Z_STREAM_END ; + ok $contents eq $Z ; -# deflate/inflate - small buffer with a number -# ============================== + # redo deflate with AppendOutput -$hello = 6529 ; - -ok(91, ($x, $err) = deflateInit( {-Bufsize => 1} ) ) ; -ok(92, $x) ; -ok(93, $err == Z_OK) ; - -$Answer = ''; -{ - ($X, $status) = $x->deflate($hello) ; + ok (($k, $err) = new Compress::Zlib::Inflate(-AppendOutput => 1)) ; + ok $k ; + cmp_ok $err, '==', Z_OK ; + + my $s ; + my $out ; + my @bits = split('', $keep) ; + foreach my $bit (@bits) { + $s = $k->inflate($bit, $out) ; + } + + cmp_ok $s, '==', Z_STREAM_END ; + + ok $contents eq $out ; - $Answer .= $X ; -} - -ok(94, $status == Z_OK) ; -ok(95, (($X, $status) = $x->flush())[1] == Z_OK ) ; -$Answer .= $X ; - - -@Answer = split('', $Answer) ; - -ok(96, ($k, $err) = inflateInit( {-Bufsize => 1}) ) ; -ok(97, $k) ; -ok(98, $err == Z_OK) ; - -$GOT = ''; -foreach (@Answer) -{ - ($Z, $status) = $k->inflate($_) ; - $GOT .= $Z ; - last if $status == Z_STREAM_END or $status != Z_OK ; - } - -ok(99, $status == Z_STREAM_END) ; -ok(100, $GOT eq $hello ) ; - - -# deflate/inflate - larger buffer -# ============================== +{ + title "deflate/inflate - preset dictionary"; + # =================================== -ok(101, $x = deflateInit() ) ; + my $dictionary = "hello" ; + ok my $x = new Compress::Zlib::Deflate({-Level => Z_BEST_COMPRESSION, + -Dictionary => $dictionary}) ; -ok(102, (($X, $status) = $x->deflate($contents))[1] == Z_OK) ; + my $dictID = $x->dict_adler() ; -my $Y = $X ; - - -ok(103, (($X, $status) = $x->flush() )[1] == Z_OK ) ; -$Y .= $X ; - - - -ok(104, $k = inflateInit() ) ; + my ($X, $Y, $Z); + cmp_ok $x->deflate($hello, $X), '==', Z_OK; + cmp_ok $x->flush($Y), '==', Z_OK; + $X .= $Y ; -($Z, $status) = $k->inflate($Y) ; + ok my $k = new Compress::Zlib::Inflate(-Dictionary => $dictionary) ; -ok(105, $status == Z_STREAM_END) ; -ok(106, $contents eq $Z ) ; + cmp_ok $k->inflate($X, $Z), '==', Z_STREAM_END; + is $k->dict_adler(), $dictID; + is $hello, $Z ; -# deflate/inflate - preset dictionary -# =================================== +} -my $dictionary = "hello" ; -ok(107, $x = deflateInit({-Level => Z_BEST_COMPRESSION, - -Dictionary => $dictionary})) ; - -my $dictID = $x->dict_adler() ; - -($X, $status) = $x->deflate($hello) ; -ok(108, $status == Z_OK) ; -($Y, $status) = $x->flush() ; -ok(109, $status == Z_OK) ; -$X .= $Y ; -$x = 0 ; - -ok(110, $k = inflateInit(-Dictionary => $dictionary) ) ; - -($Z, $status) = $k->inflate($X); -ok(111, $status == Z_STREAM_END) ; -ok(112, $k->dict_adler() == $dictID); -ok(113, $hello eq $Z ) ; - -##ok(76, $k->inflateSetDictionary($dictionary) == Z_OK); -# -#$Z=''; -#while (1) { -# ($Z, $status) = $k->inflate($X) ; -# last if $status == Z_STREAM_END or $status != Z_OK ; -#print "status=[$status] hello=[$hello] Z=[$Z]\n"; -#} -#ok(77, $status == Z_STREAM_END) ; -#ok(78, $hello eq $Z ) ; -#print "status=[$status] hello=[$hello] Z=[$Z]\n"; -# -# -## all done. -# -# -# - - -# inflate - check remaining buffer after Z_STREAM_END +title 'inflate - check remaining buffer after Z_STREAM_END'; +# and that ConsumeInput works. # =================================================== +for my $consume ( 0 .. 1) { - ok(114, $x = deflateInit(-Level => Z_BEST_COMPRESSION )) ; + ok my $x = new Compress::Zlib::Deflate(-Level => Z_BEST_COMPRESSION ) ; - ($X, $status) = $x->deflate($hello) ; - ok(115, $status == Z_OK) ; - ($Y, $status) = $x->flush() ; - ok(116, $status == Z_OK) ; + my ($X, $Y, $Z); + cmp_ok $x->deflate($hello, $X), '==', Z_OK; + cmp_ok $x->flush($Y), '==', Z_OK; $X .= $Y ; - $x = 0 ; - ok(117, $k = inflateInit() ) ; + ok my $k = new Compress::Zlib::Inflate( -ConsumeInput => $consume) ; my $first = substr($X, 0, 2) ; + my $remember_first = $first ; my $last = substr($X, 2) ; - ($Z, $status) = $k->inflate($first); - ok(118, $status == Z_OK) ; - ok(119, $first eq "") ; + cmp_ok $k->inflate($first, $Z), '==', Z_OK; + if ($consume) { + ok $first eq "" ; + } + else { + ok $first eq $remember_first ; + } + my $T ; $last .= "appendage" ; - my ($T, $status) = $k->inflate($last); - ok(120, $status == Z_STREAM_END) ; - ok(121, $hello eq $Z . $T ) ; - ok(122, $last eq "appendage") ; - -} - -# memGzip & memGunzip -{ - my $name = "test.gz" ; - my $buffer = <<EOM; -some sample -text - -EOM - - my $len = length $buffer ; - my ($x, $uncomp) ; - - - # create an in-memory gzip file - my $dest = Compress::Zlib::memGzip($buffer) ; - ok(123, length $dest) ; - - # write it to disk - ok(124, open(FH, ">$name")) ; - binmode(FH); - print FH $dest ; - close FH ; - - # uncompress with gzopen - ok(125, my $fil = gzopen($name, "rb") ) ; - - ok(126, ($x = $fil->gzread($uncomp)) == $len) ; - - ok(127, ! $fil->gzclose ) ; - - ok(128, $uncomp eq $buffer) ; - - unlink $name ; - - # now check that memGunzip can deal with it. - my $ungzip = Compress::Zlib::memGunzip($dest) ; - ok(129, defined $ungzip) ; - ok(130, $buffer eq $ungzip) ; - - # now do the same but use a reference - - $dest = Compress::Zlib::memGzip(\$buffer) ; - ok(131, length $dest) ; - - # write it to disk - ok(132, open(FH, ">$name")) ; - binmode(FH); - print FH $dest ; - close FH ; - - # uncompress with gzopen - ok(133, $fil = gzopen($name, "rb") ) ; - - ok(134, ($x = $fil->gzread($uncomp)) == $len) ; - - ok(135, ! $fil->gzclose ) ; - - ok(136, $uncomp eq $buffer) ; - - # now check that memGunzip can deal with it. - my $keep = $dest; - $ungzip = Compress::Zlib::memGunzip(\$dest) ; - ok(137, defined $ungzip) ; - ok(138, $buffer eq $ungzip) ; - - # check memGunzip can cope with missing gzip trailer - my $minimal = substr($keep, 0, -1) ; - $ungzip = Compress::Zlib::memGunzip(\$minimal) ; - ok(139, defined $ungzip) ; - ok(140, $buffer eq $ungzip) ; - - $minimal = substr($keep, 0, -2) ; - $ungzip = Compress::Zlib::memGunzip(\$minimal) ; - ok(141, defined $ungzip) ; - ok(142, $buffer eq $ungzip) ; - - $minimal = substr($keep, 0, -3) ; - $ungzip = Compress::Zlib::memGunzip(\$minimal) ; - ok(143, defined $ungzip) ; - ok(144, $buffer eq $ungzip) ; - - $minimal = substr($keep, 0, -4) ; - $ungzip = Compress::Zlib::memGunzip(\$minimal) ; - ok(145, defined $ungzip) ; - ok(146, $buffer eq $ungzip) ; - - $minimal = substr($keep, 0, -5) ; - $ungzip = Compress::Zlib::memGunzip(\$minimal) ; - ok(147, defined $ungzip) ; - ok(148, $buffer eq $ungzip) ; - - $minimal = substr($keep, 0, -6) ; - $ungzip = Compress::Zlib::memGunzip(\$minimal) ; - ok(149, defined $ungzip) ; - ok(150, $buffer eq $ungzip) ; - - $minimal = substr($keep, 0, -7) ; - $ungzip = Compress::Zlib::memGunzip(\$minimal) ; - ok(151, defined $ungzip) ; - ok(152, $buffer eq $ungzip) ; - - $minimal = substr($keep, 0, -8) ; - $ungzip = Compress::Zlib::memGunzip(\$minimal) ; - ok(153, defined $ungzip) ; - ok(154, $buffer eq $ungzip) ; - - $minimal = substr($keep, 0, -9) ; - $ungzip = Compress::Zlib::memGunzip(\$minimal) ; - ok(155, ! defined $ungzip) ; - - - unlink $name ; - - # check corrupt header -- too short - $dest = "x" ; - my $result = Compress::Zlib::memGunzip($dest) ; - ok(156, !defined $result) ; + my $remember_last = $last ; + cmp_ok $k->inflate($last, $T), '==', Z_STREAM_END; + is $hello, $Z . $T ; + if ($consume) { + is $last, "appendage" ; + } + else { + is $last, $remember_last ; + } - # check corrupt header -- full of junk - $dest = "x" x 200 ; - $result = Compress::Zlib::memGunzip($dest) ; - ok(157, !defined $result) ; } -# memGunzip with a gzopen created file -{ - my $name = "test.gz" ; - my $buffer = <<EOM; -some sample -text - -EOM - - ok(158, $fil = gzopen($name, "wb")) ; - ok(159, $fil->gzwrite($buffer) == length $buffer) ; - - ok(160, ! $fil->gzclose ) ; - - my $compr = readFile($name); - ok(161, length $compr) ; - my $unc = Compress::Zlib::memGunzip($compr) ; - ok(162, defined $unc) ; - ok(163, $buffer eq $unc) ; - unlink $name ; -} { - # Check - MAX_WBITS + title 'Check - MAX_WBITS'; # ================= - $hello = "Test test test test test"; - @hello = split('', $hello) ; - - ok(164, ($x, $err) = deflateInit( -Bufsize => 1, -WindowBits => -MAX_WBITS() ) ) ; - ok(165, $x) ; - ok(166, $err == Z_OK) ; - - $Answer = ''; + my $hello = "Test test test test test"; + my @hello = split('', $hello) ; + + ok my ($x, $err) = + new Compress::Zlib::Deflate ( -Bufsize => 1, + -WindowBits => -MAX_WBITS(), + -AppendOutput => 1 ) ; + ok $x ; + cmp_ok $err, '==', Z_OK ; + + my $Answer = ''; + my $status; foreach (@hello) { - ($X, $status) = $x->deflate($_) ; + $status = $x->deflate($_, $Answer) ; last unless $status == Z_OK ; - - $Answer .= $X ; } - ok(167, $status == Z_OK) ; + cmp_ok $status, '==', Z_OK ; - ok(168, (($X, $status) = $x->flush())[1] == Z_OK ) ; - $Answer .= $X ; + cmp_ok $x->flush($Answer), '==', Z_OK ; - - @Answer = split('', $Answer) ; + my @Answer = split('', $Answer) ; # Undocumented corner -- extra byte needed to get inflate to return # Z_STREAM_END when done. push @Answer, " " ; - ok(169, ($k, $err) = inflateInit(-Bufsize => 1, -WindowBits => -MAX_WBITS()) ) ; - ok(170, $k) ; - ok(171, $err == Z_OK) ; + my $k; + ok(($k, $err) = new Compress::Zlib::Inflate( + {-Bufsize => 1, + -AppendOutput =>1, + -WindowBits => -MAX_WBITS()})) ; + ok $k ; + cmp_ok $err, '==', Z_OK ; - $GOT = ''; + my $GOT = ''; foreach (@Answer) { - ($Z, $status) = $k->inflate($_) ; - $GOT .= $Z ; + $status = $k->inflate($_, $GOT) ; last if $status == Z_STREAM_END or $status != Z_OK ; } - ok(172, $status == Z_STREAM_END) ; - ok(173, $GOT eq $hello ) ; + cmp_ok $status, '==', Z_STREAM_END ; + is $GOT, $hello ; } { - # inflateSync + title 'inflateSync'; # create a deflate stream with flush points my $hello = "I am a HAL 9000 computer" x 2001 ; my $goodbye = "Will I dream?" x 2010; - my ($err, $answer, $X, $status, $Answer); + my ($x, $err, $answer, $X, $Z, $status); + my $Answer ; - ok(174, ($x, $err) = deflateInit() ) ; - ok(175, $x) ; - ok(176, $err == Z_OK) ; + #use Devel::Peek ; + ok(($x, $err) = new Compress::Zlib::Deflate(AppendOutput => 1)) ; + ok $x ; + cmp_ok $err, '==', Z_OK ; - ($Answer, $status) = $x->deflate($hello) ; - ok(177, $status == Z_OK) ; + cmp_ok $x->deflate($hello, $Answer), '==', Z_OK; # create a flush point - ok(178, (($X, $status) = $x->flush(Z_FULL_FLUSH))[1] == Z_OK ) ; - $Answer .= $X ; + cmp_ok $x->flush($Answer, Z_FULL_FLUSH), '==', Z_OK ; - ($X, $status) = $x->deflate($goodbye) ; - ok(179, $status == Z_OK) ; - $Answer .= $X ; + cmp_ok $x->deflate($goodbye, $Answer), '==', Z_OK; - ok(180, (($X, $status) = $x->flush())[1] == Z_OK ) ; - $Answer .= $X ; + cmp_ok $x->flush($Answer), '==', Z_OK ; my ($first, @Answer) = split('', $Answer) ; my $k; - ok(181, ($k, $err) = inflateInit()) ; - ok(182, $k) ; - ok(183, $err == Z_OK) ; + ok(($k, $err) = new Compress::Zlib::Inflate()) ; + ok $k ; + cmp_ok $err, '==', Z_OK ; - ($Z, $status) = $k->inflate($first) ; - ok(184, $status == Z_OK) ; + cmp_ok $k->inflate($first, $Z), '==', Z_OK; # skip to the first flush point. while (@Answer) @@ -733,189 +458,355 @@ EOM my $byte = shift @Answer; $status = $k->inflateSync($byte) ; last unless $status == Z_DATA_ERROR; - } - ok(185, $status == Z_OK); + cmp_ok $status, '==', Z_OK; my $GOT = ''; - my $Z = ''; foreach (@Answer) { my $Z = ''; - ($Z, $status) = $k->inflate($_) ; + $status = $k->inflate($_, $Z) ; $GOT .= $Z if defined $Z ; # print "x $status\n"; last if $status == Z_STREAM_END or $status != Z_OK ; } - # zlib 1.0.9 returns Z_STREAM_END here, all others return Z_DATA_ERROR - ok(186, $status == Z_DATA_ERROR || $status == Z_STREAM_END) ; - ok(187, $GOT eq $goodbye ) ; + cmp_ok $status, '==', Z_DATA_ERROR ; + is $GOT, $goodbye ; # Check inflateSync leaves good data in buffer - $Answer =~ /^(.)(.*)$/ ; - my ($initial, $rest) = ($1, $2); + my $rest = $Answer ; + $rest =~ s/^(.)//; + my $initial = $1 ; - ok(188, ($k, $err) = inflateInit()) ; - ok(189, $k) ; - ok(190, $err == Z_OK) ; + ok(($k, $err) = new Compress::Zlib::Inflate(-ConsumeInput => 0)) ; + ok $k ; + cmp_ok $err, '==', Z_OK ; - ($Z, $status) = $k->inflate($initial) ; - ok(191, $status == Z_OK) ; + cmp_ok $k->inflate($initial, $Z), '==', Z_OK; - $status = $k->inflateSync($rest) ; - ok(192, $status == Z_OK); - - ($GOT, $status) = $k->inflate($rest) ; + # Skip to the flush point + $status = $k->inflateSync($rest); + cmp_ok $status, '==', Z_OK + or diag "status '$status'\nlength rest is " . length($rest) . "\n" ; - ok(193, $status == Z_DATA_ERROR) ; - ok(194, $Z . $GOT eq $goodbye ) ; + cmp_ok $k->inflate($rest, $GOT), '==', Z_DATA_ERROR; + is $Z . $GOT, $goodbye ; } { - # deflateParams + title 'deflateParams'; my $hello = "I am a HAL 9000 computer" x 2001 ; my $goodbye = "Will I dream?" x 2010; - my ($input, $err, $answer, $X, $status, $Answer); + my ($x, $input, $err, $answer, $X, $status, $Answer); - ok(195, ($x, $err) = deflateInit(-Level => Z_BEST_COMPRESSION, - -Strategy => Z_DEFAULT_STRATEGY) ) ; - ok(196, $x) ; - ok(197, $err == Z_OK) ; + ok(($x, $err) = new Compress::Zlib::Deflate( + -AppendOutput => 1, + -Level => Z_DEFAULT_COMPRESSION, + -Strategy => Z_DEFAULT_STRATEGY)) ; + ok $x ; + cmp_ok $err, '==', Z_OK ; - ok(198, $x->get_Level() == Z_BEST_COMPRESSION); - ok(199, $x->get_Strategy() == Z_DEFAULT_STRATEGY); + ok $x->get_Level() == Z_DEFAULT_COMPRESSION; + ok $x->get_Strategy() == Z_DEFAULT_STRATEGY; - ($Answer, $status) = $x->deflate($hello) ; - ok(200, $status == Z_OK) ; + $status = $x->deflate($hello, $Answer) ; + cmp_ok $status, '==', Z_OK ; $input .= $hello; # error cases eval { $x->deflateParams() }; - ok(201, $@ =~ m#^deflateParams needs Level and/or Strategy#); + like $@, mkErr('^Compress::Zlib::deflateParams needs Level and\/or Strategy'); + + eval { $x->deflateParams(-Bufsize => 0) }; + like $@, mkErr('^Compress::Zlib::Inflate::deflateParams: Bufsize must be >= 1, you specified 0'); eval { $x->deflateParams(-Joe => 3) }; - ok(202, $@ =~ /^unknown key value\(s\) Joe at/); + like $@, mkErr('^Compress::Zlib::deflateStream::deflateParams: unknown key value\(s\) Joe'); - ok(203, $x->get_Level() == Z_BEST_COMPRESSION); - ok(204, $x->get_Strategy() == Z_DEFAULT_STRATEGY); + is $x->get_Level(), Z_DEFAULT_COMPRESSION; + is $x->get_Strategy(), Z_DEFAULT_STRATEGY; # change both Level & Strategy - $status = $x->deflateParams(-Level => Z_BEST_SPEED, -Strategy => Z_HUFFMAN_ONLY) ; - ok(205, $status == Z_OK) ; + $status = $x->deflateParams(-Level => Z_BEST_SPEED, -Strategy => Z_HUFFMAN_ONLY, -Bufsize => 1234) ; + cmp_ok $status, '==', Z_OK ; - ok(206, $x->get_Level() == Z_BEST_SPEED); - ok(207, $x->get_Strategy() == Z_HUFFMAN_ONLY); + is $x->get_Level(), Z_BEST_SPEED; + is $x->get_Strategy(), Z_HUFFMAN_ONLY; - ($X, $status) = $x->deflate($goodbye) ; - ok(208, $status == Z_OK) ; - $Answer .= $X ; + $status = $x->deflate($goodbye, $Answer) ; + cmp_ok $status, '==', Z_OK ; $input .= $goodbye; # change only Level $status = $x->deflateParams(-Level => Z_NO_COMPRESSION) ; - ok(209, $status == Z_OK) ; + cmp_ok $status, '==', Z_OK ; - ok(210, $x->get_Level() == Z_NO_COMPRESSION); - ok(211, $x->get_Strategy() == Z_HUFFMAN_ONLY); + is $x->get_Level(), Z_NO_COMPRESSION; + is $x->get_Strategy(), Z_HUFFMAN_ONLY; - ($X, $status) = $x->deflate($goodbye) ; - ok(212, $status == Z_OK) ; - $Answer .= $X ; + $status = $x->deflate($goodbye, $Answer) ; + cmp_ok $status, '==', Z_OK ; $input .= $goodbye; # change only Strategy $status = $x->deflateParams(-Strategy => Z_FILTERED) ; - ok(213, $status == Z_OK) ; + cmp_ok $status, '==', Z_OK ; - ok(214, $x->get_Level() == Z_NO_COMPRESSION); - ok(215, $x->get_Strategy() == Z_FILTERED); + is $x->get_Level(), Z_NO_COMPRESSION; + is $x->get_Strategy(), Z_FILTERED; - ($X, $status) = $x->deflate($goodbye) ; - ok(216, $status == Z_OK) ; - $Answer .= $X ; + $status = $x->deflate($goodbye, $Answer) ; + cmp_ok $status, '==', Z_OK ; $input .= $goodbye; - ok(217, (($X, $status) = $x->flush())[1] == Z_OK ) ; - $Answer .= $X ; - - my ($first, @Answer) = split('', $Answer) ; + cmp_ok $x->flush($Answer), '==', Z_OK ; my $k; - ok(218, ($k, $err) = inflateInit()) ; - ok(219, $k) ; - ok(220, $err == Z_OK) ; + ok(($k, $err) = new Compress::Zlib::Inflate()) ; + ok $k ; + cmp_ok $err, '==', Z_OK ; - ($Z, $status) = $k->inflate($Answer) ; + my $Z; + $status = $k->inflate($Answer, $Z) ; - ok(221, $status == Z_STREAM_END) ; - ok(222, $Z eq $input ) ; + cmp_ok $status, '==', Z_STREAM_END ; + is $Z, $input ; } + { - # error cases + title "ConsumeInput and a read-only buffer trapped" ; + + ok my $k = new Compress::Zlib::Inflate(-ConsumeInput => 1) ; + + my $Z; + eval { $k->inflate("abc", $Z) ; }; + like $@, mkErr("Compress::Zlib::Inflate::inflate input parameter cannot be read-only when ConsumeInput is specified"); + +} - eval { deflateInit(-Level) }; - ok(223, $@ =~ /^Compress::Zlib::deflateInit: parameter is not a reference to a hash at/); +foreach (1 .. 2) +{ + next if $[ < 5.005 ; - eval { inflateInit(-Level) }; - ok(224, $@ =~ /^Compress::Zlib::inflateInit: parameter is not a reference to a hash at/); + title 'test inflate/deflate with a substr'; - eval { deflateInit(-Joe => 1) }; - ok(225, $@ =~ /^unknown key value\(s\) Joe at/); + my $contents = '' ; + foreach (1 .. 5000) + { $contents .= chr int rand 255 } + ok my $x = new Compress::Zlib::Deflate(-AppendOutput => 1) ; + + my $X ; + my $status = $x->deflate(substr($contents,0), $X); + cmp_ok $status, '==', Z_OK ; + + cmp_ok $x->flush($X), '==', Z_OK ; + + my $append = "Appended" ; + $X .= $append ; + + ok my $k = new Compress::Zlib::Inflate(-AppendOutput => 1) ; + + my $Z; + my $keep = $X ; + $status = $k->inflate(substr($X, 0), $Z) ; + + cmp_ok $status, '==', Z_STREAM_END ; + #print "status $status X [$X]\n" ; + is $contents, $Z ; + ok $X eq $append; + #is length($X), length($append); + #ok $X eq $keep; + #is length($X), length($keep); +} + +title 'Looping Append test - checks that deRef_l resets the output buffer'; +foreach (1 .. 2) +{ - eval { inflateInit(-Joe => 1) }; - ok(226, $@ =~ /^unknown key value\(s\) Joe at/); + my $hello = "I am a HAL 9000 computer" ; + my @hello = split('', $hello) ; + my ($err, $x, $X, $status); + + ok( ($x, $err) = new Compress::Zlib::Deflate ( -Bufsize => 1 ) ); + ok $x ; + cmp_ok $err, '==', Z_OK ; + + $X = "" ; + my $Answer = ''; + foreach (@hello) + { + $status = $x->deflate($_, $X) ; + last unless $status == Z_OK ; + + $Answer .= $X ; + } + + cmp_ok $status, '==', Z_OK ; + + cmp_ok $x->flush($X), '==', Z_OK ; + $Answer .= $X ; + + my @Answer = split('', $Answer) ; + + my $k; + ok(($k, $err) = new Compress::Zlib::Inflate(-AppendOutput => 1) ); + ok $k ; + cmp_ok $err, '==', Z_OK ; + + my $GOT ; + my $Z; + $Z = 1 ;#x 2000 ; + foreach (@Answer) + { + $status = $k->inflate($_, $GOT) ; + last if $status == Z_STREAM_END or $status != Z_OK ; + } + + cmp_ok $status, '==', Z_STREAM_END ; + is $GOT, $hello ; - eval { deflateInit(-Bufsize => 0) }; - ok(227, $@ =~ /^.*?: Bufsize must be >= 1, you specified 0 at/); +} - eval { inflateInit(-Bufsize => 0) }; - ok(228, $@ =~ /^.*?: Bufsize must be >= 1, you specified 0 at/); +if ($] >= 5.005) +{ + title 'test inflate input parameter via substr'; - eval { deflateInit(-Bufsize => -1) }; - ok(229, $@ =~ /^.*?: Bufsize must be >= 1, you specified -1 at/); + my $hello = "I am a HAL 9000 computer" ; + my $data = $hello ; - eval { inflateInit(-Bufsize => -1) }; - ok(230, $@ =~ /^.*?: Bufsize must be >= 1, you specified -1 at/); + my($X, $Z); - eval { deflateInit(-Bufsize => "xxx") }; - ok(231, $@ =~ /^.*?: Bufsize must be >= 1, you specified xxx at/); + ok my $x = new Compress::Zlib::Deflate ( -AppendOutput => 1 ); - eval { inflateInit(-Bufsize => "xxx") }; - ok(232, $@ =~ /^.*?: Bufsize must be >= 1, you specified xxx at/); + cmp_ok $x->deflate($data, $X), '==', Z_OK ; + cmp_ok $x->flush($X), '==', Z_OK ; + + my $append = "Appended" ; + $X .= $append ; + my $keep = $X ; + + ok my $k = new Compress::Zlib::Inflate ( -AppendOutput => 1, + -ConsumeInput => 1 ) ; + +# cmp_ok $k->inflate(substr($X, 0, -1), $Z), '==', Z_STREAM_END ; ; + cmp_ok $k->inflate(substr($X, 0), $Z), '==', Z_STREAM_END ; ; + + ok $hello eq $Z ; + is $X, $append; + + $X = $keep ; + $Z = ''; + ok $k = new Compress::Zlib::Inflate ( -AppendOutput => 1, + -ConsumeInput => 0 ) ; + + cmp_ok $k->inflate(substr($X, 0, -1), $Z), '==', Z_STREAM_END ; ; + #cmp_ok $k->inflate(substr($X, 0), $Z), '==', Z_STREAM_END ; ; + + ok $hello eq $Z ; + is $X, $keep; + } +exit if $] < 5.006 ; + +title 'Looping Append test with substr output - substr the end of the string'; +foreach (1 .. 2) { - # test inflate with a substr - ok(233, my $x = deflateInit() ) ; + my $hello = "I am a HAL 9000 computer" ; + my @hello = split('', $hello) ; + my ($err, $x, $X, $status); + + ok( ($x, $err) = new Compress::Zlib::Deflate ( -Bufsize => 1, + -AppendOutput => 1 ) ); + ok $x ; + cmp_ok $err, '==', Z_OK ; + + $X = "" ; + my $Answer = ''; + foreach (@hello) + { + $status = $x->deflate($_, substr($Answer, length($Answer))) ; + last unless $status == Z_OK ; + + } - ok(234, (my ($X, $status) = $x->deflate($contents))[1] == Z_OK) ; + cmp_ok $status, '==', Z_OK ; - my $Y = $X ; - + cmp_ok $x->flush(substr($Answer, length($Answer))), '==', Z_OK ; + my @Answer = split('', $Answer) ; - ok(235, (($X, $status) = $x->flush() )[1] == Z_OK ) ; - $Y .= $X ; + my $k; + ok(($k, $err) = new Compress::Zlib::Inflate(-AppendOutput => 1) ); + ok $k ; + cmp_ok $err, '==', Z_OK ; + + my $GOT = ''; + my $Z; + $Z = 1 ;#x 2000 ; + foreach (@Answer) + { + $status = $k->inflate($_, substr($GOT, length($GOT))) ; + last if $status == Z_STREAM_END or $status != Z_OK ; + } - my $append = "Appended" ; - $Y .= $append ; + cmp_ok $status, '==', Z_STREAM_END ; + is $GOT, $hello ; + +} + +title 'Looping Append test with substr output - substr the complete string'; +foreach (1 .. 2) +{ + + my $hello = "I am a HAL 9000 computer" ; + my @hello = split('', $hello) ; + my ($err, $x, $X, $status); + + ok( ($x, $err) = new Compress::Zlib::Deflate ( -Bufsize => 1, + -AppendOutput => 1 ) ); + ok $x ; + cmp_ok $err, '==', Z_OK ; + + $X = "" ; + my $Answer = ''; + foreach (@hello) + { + $status = $x->deflate($_, substr($Answer, 0)) ; + last unless $status == Z_OK ; + + } + + cmp_ok $status, '==', Z_OK ; + + cmp_ok $x->flush(substr($Answer, 0)), '==', Z_OK ; - ok(236, $k = inflateInit() ) ; + my @Answer = split('', $Answer) ; - ($Z, $status) = $k->inflate(substr($Y, 0, -1)) ; + my $k; + ok(($k, $err) = new Compress::Zlib::Inflate(-AppendOutput => 1) ); + ok $k ; + cmp_ok $err, '==', Z_OK ; + + my $GOT = ''; + my $Z; + $Z = 1 ;#x 2000 ; + foreach (@Answer) + { + $status = $k->inflate($_, substr($GOT, 0)) ; + last if $status == Z_STREAM_END or $status != Z_OK ; + } - ok(237, $status == Z_STREAM_END) ; - #print "status $status Y [$Y]\n" ; - ok(238, $contents eq $Z ) ; - ok(239, $Y eq $append); - + cmp_ok $status, '==', Z_STREAM_END ; + is $GOT, $hello ; } + diff --git a/ext/Compress/Zlib/t/03zlib-v1.t b/ext/Compress/Zlib/t/03zlib-v1.t new file mode 100644 index 0000000000..a0950c24ab --- /dev/null +++ b/ext/Compress/Zlib/t/03zlib-v1.t @@ -0,0 +1,1058 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; +use Symbol; + +BEGIN +{ + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + my $count = 0 ; + if ($] < 5.005) { + $count = 340 ; + } + else { + $count = 351 ; + } + + + plan tests => $count + $extra ; + + use_ok('Compress::Zlib', 2) ; + use_ok('Compress::Gzip::Constants') ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; +} + + +my $hello = <<EOM ; +hello world +this is a test +EOM + +my $len = length $hello ; + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + +# generate a long random string +my $contents = '' ; +foreach (1 .. 5000) + { $contents .= chr int rand 256 } + +my $x ; +my $fil; + +# compress/uncompress tests +# ========================= + +eval { compress([1]); }; +ok $@ =~ m#not a scalar reference# + or print "# $@\n" ;; + +eval { uncompress([1]); }; +ok $@ =~ m#not a scalar reference# + or print "# $@\n" ;; + +$hello = "hello mum" ; +my $keep_hello = $hello ; + +my $compr = compress($hello) ; +ok $compr ne "" ; + +my $keep_compr = $compr ; + +my $uncompr = uncompress ($compr) ; + +ok $hello eq $uncompr ; + +ok $hello eq $keep_hello ; +ok $compr eq $keep_compr ; + +# compress a number +$hello = 7890 ; +$keep_hello = $hello ; + +$compr = compress($hello) ; +ok $compr ne "" ; + +$keep_compr = $compr ; + +$uncompr = uncompress ($compr) ; + +ok $hello eq $uncompr ; + +ok $hello eq $keep_hello ; +ok $compr eq $keep_compr ; + +# bigger compress + +$compr = compress ($contents) ; +ok $compr ne "" ; + +$uncompr = uncompress ($compr) ; + +ok $contents eq $uncompr ; + +# buffer reference + +$compr = compress(\$hello) ; +ok $compr ne "" ; + + +$uncompr = uncompress (\$compr) ; +ok $hello eq $uncompr ; + +# bad level +$compr = compress($hello, 1000) ; +ok ! defined $compr; + +# change level +$compr = compress($hello, Z_BEST_COMPRESSION) ; +ok defined $compr; +$uncompr = uncompress (\$compr) ; +ok $hello eq $uncompr ; + +# corrupt data +$compr = compress(\$hello) ; +ok $compr ne "" ; + +substr($compr,0, 1) = "\xFF"; +ok !defined uncompress (\$compr) ; + +# deflate/inflate - small buffer +# ============================== + +$hello = "I am a HAL 9000 computer" ; +my @hello = split('', $hello) ; +my ($err, $X, $status); + +ok (($x, $err) = deflateInit( {-Bufsize => 1} ) ) ; +ok $x ; +ok $err == Z_OK ; + +my $Answer = ''; +foreach (@hello) +{ + ($X, $status) = $x->deflate($_) ; + last unless $status == Z_OK ; + + $Answer .= $X ; +} + +ok $status == Z_OK ; + +ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; +$Answer .= $X ; + + +my @Answer = split('', $Answer) ; + +my $k; +ok (($k, $err) = inflateInit( {-Bufsize => 1}) ) ; +ok $k ; +ok $err == Z_OK ; + +my $GOT = ''; +my $Z; +foreach (@Answer) +{ + ($Z, $status) = $k->inflate($_) ; + $GOT .= $Z ; + last if $status == Z_STREAM_END or $status != Z_OK ; + +} + +ok $status == Z_STREAM_END ; +ok $GOT eq $hello ; + + +title 'deflate/inflate - small buffer with a number'; +# ============================== + +$hello = 6529 ; + +ok (($x, $err) = deflateInit( {-Bufsize => 1} ) ) ; +ok $x ; +ok $err == Z_OK ; + +ok !defined $x->msg() ; +ok $x->total_in() == 0 ; +ok $x->total_out() == 0 ; +$Answer = ''; +{ + ($X, $status) = $x->deflate($hello) ; + + $Answer .= $X ; +} + +ok $status == Z_OK ; + +ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; +$Answer .= $X ; + +ok !defined $x->msg() ; +ok $x->total_in() == length $hello ; +ok $x->total_out() == length $Answer ; + + +@Answer = split('', $Answer) ; + +ok (($k, $err) = inflateInit( {-Bufsize => 1}) ) ; +ok $k ; +ok $err == Z_OK ; + +ok !defined $k->msg() ; +ok $k->total_in() == 0 ; +ok $k->total_out() == 0 ; + +$GOT = ''; +foreach (@Answer) +{ + ($Z, $status) = $k->inflate($_) ; + $GOT .= $Z ; + last if $status == Z_STREAM_END or $status != Z_OK ; + +} + +ok $status == Z_STREAM_END ; +ok $GOT eq $hello ; + +ok !defined $k->msg() ; +is $k->total_in(), length $Answer ; +ok $k->total_out() == length $hello ; + + + +title 'deflate/inflate - larger buffer'; +# ============================== + + +ok $x = deflateInit() ; + +ok ((($X, $status) = $x->deflate($contents))[1] == Z_OK) ; + +my $Y = $X ; + + +ok ((($X, $status) = $x->flush() )[1] == Z_OK ) ; +$Y .= $X ; + + + +ok $k = inflateInit() ; + +($Z, $status) = $k->inflate($Y) ; + +ok $status == Z_STREAM_END ; +ok $contents eq $Z ; + +title 'deflate/inflate - preset dictionary'; +# =================================== + +my $dictionary = "hello" ; +ok $x = deflateInit({-Level => Z_BEST_COMPRESSION, + -Dictionary => $dictionary}) ; + +my $dictID = $x->dict_adler() ; + +($X, $status) = $x->deflate($hello) ; +ok $status == Z_OK ; +($Y, $status) = $x->flush() ; +ok $status == Z_OK ; +$X .= $Y ; +$x = 0 ; + +ok $k = inflateInit(-Dictionary => $dictionary) ; + +($Z, $status) = $k->inflate($X); +ok $status == Z_STREAM_END ; +ok $k->dict_adler() == $dictID; +ok $hello eq $Z ; + +#$Z=''; +#while (1) { +# ($Z, $status) = $k->inflate($X) ; +# last if $status == Z_STREAM_END or $status != Z_OK ; +#print "status=[$status] hello=[$hello] Z=[$Z]\n"; +#} +#ok $status == Z_STREAM_END ; +#ok $hello eq $Z +# or print "status=[$status] hello=[$hello] Z=[$Z]\n"; + + + + + + +title 'inflate - check remaining buffer after Z_STREAM_END'; +# =================================================== + +{ + ok $x = deflateInit(-Level => Z_BEST_COMPRESSION ) ; + + ($X, $status) = $x->deflate($hello) ; + ok $status == Z_OK ; + ($Y, $status) = $x->flush() ; + ok $status == Z_OK ; + $X .= $Y ; + $x = 0 ; + + ok $k = inflateInit() ; + + my $first = substr($X, 0, 2) ; + my $last = substr($X, 2) ; + ($Z, $status) = $k->inflate($first); + ok $status == Z_OK ; + ok $first eq "" ; + + $last .= "appendage" ; + my $T; + ($T, $status) = $k->inflate($last); + ok $status == Z_STREAM_END ; + ok $hello eq $Z . $T ; + ok $last eq "appendage" ; + +} + +title 'memGzip & memGunzip'; +{ + my $name = "test.gz" ; + my $buffer = <<EOM; +some sample +text + +EOM + + my $len = length $buffer ; + my ($x, $uncomp) ; + + + # create an in-memory gzip file + my $dest = Compress::Zlib::memGzip($buffer) ; + ok length $dest ; + + # write it to disk + ok open(FH, ">$name") ; + binmode(FH); + print FH $dest ; + close FH ; + + # uncompress with gzopen + ok my $fil = gzopen($name, "rb") ; + + is $fil->gzread($uncomp, 0), 0 ; + ok (($x = $fil->gzread($uncomp)) == $len) ; + + ok ! $fil->gzclose ; + + ok $uncomp eq $buffer ; + + unlink $name ; + + # now check that memGunzip can deal with it. + my $ungzip = Compress::Zlib::memGunzip($dest) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + # now do the same but use a reference + + $dest = Compress::Zlib::memGzip(\$buffer) ; + ok length $dest ; + + # write it to disk + ok open(FH, ">$name") ; + binmode(FH); + print FH $dest ; + close FH ; + + # uncompress with gzopen + ok $fil = gzopen($name, "rb") ; + + ok (($x = $fil->gzread($uncomp)) == $len) ; + + ok ! $fil->gzclose ; + + ok $uncomp eq $buffer ; + + # now check that memGunzip can deal with it. + my $keep = $dest; + $ungzip = Compress::Zlib::memGunzip(\$dest) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + # check memGunzip can cope with missing gzip trailer + my $minimal = substr($keep, 0, -1) ; + $ungzip = Compress::Zlib::memGunzip(\$minimal) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + $minimal = substr($keep, 0, -2) ; + $ungzip = Compress::Zlib::memGunzip(\$minimal) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + $minimal = substr($keep, 0, -3) ; + $ungzip = Compress::Zlib::memGunzip(\$minimal) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + $minimal = substr($keep, 0, -4) ; + $ungzip = Compress::Zlib::memGunzip(\$minimal) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + $minimal = substr($keep, 0, -5) ; + $ungzip = Compress::Zlib::memGunzip(\$minimal) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + $minimal = substr($keep, 0, -6) ; + $ungzip = Compress::Zlib::memGunzip(\$minimal) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + $minimal = substr($keep, 0, -7) ; + $ungzip = Compress::Zlib::memGunzip(\$minimal) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + $minimal = substr($keep, 0, -8) ; + $ungzip = Compress::Zlib::memGunzip(\$minimal) ; + ok defined $ungzip ; + ok $buffer eq $ungzip ; + + $minimal = substr($keep, 0, -9) ; + $ungzip = Compress::Zlib::memGunzip(\$minimal) ; + ok ! defined $ungzip ; + + + unlink $name ; + + # check corrupt header -- too short + $dest = "x" ; + my $result = Compress::Zlib::memGunzip($dest) ; + ok !defined $result ; + + # check corrupt header -- full of junk + $dest = "x" x 200 ; + $result = Compress::Zlib::memGunzip($dest) ; + ok !defined $result ; + + # corrupt header - 1st byte wrong + my $bad = $keep ; + substr($bad, 0, 1) = "\xFF" ; + $ungzip = Compress::Zlib::memGunzip(\$bad) ; + ok ! defined $ungzip ; + + # corrupt header - 2st byte wrong + $bad = $keep ; + substr($bad, 1, 1) = "\xFF" ; + $ungzip = Compress::Zlib::memGunzip(\$bad) ; + ok ! defined $ungzip ; + + # corrupt header - method not deflated + $bad = $keep ; + substr($bad, 2, 1) = "\xFF" ; + $ungzip = Compress::Zlib::memGunzip(\$bad) ; + ok ! defined $ungzip ; + + # corrupt header - reserverd bits used + $bad = $keep ; + substr($bad, 3, 1) = "\xFF" ; + $ungzip = Compress::Zlib::memGunzip(\$bad) ; + ok ! defined $ungzip ; + + # corrupt trailer - length wrong + $bad = $keep ; + substr($bad, -8, 4) = "\xFF" x 4 ; + $ungzip = Compress::Zlib::memGunzip(\$bad) ; + ok ! defined $ungzip ; + + # corrupt trailer - CRC wrong + $bad = $keep ; + substr($bad, -4, 4) = "\xFF" x 4 ; + $ungzip = Compress::Zlib::memGunzip(\$bad) ; + ok ! defined $ungzip ; +} + +title 'memGunzip with a gzopen created file'; +{ + my $name = "test.gz" ; + my $buffer = <<EOM; +some sample +text + +EOM + + ok $fil = gzopen($name, "wb") ; + + ok $fil->gzwrite($buffer) == length $buffer ; + + ok ! $fil->gzclose ; + + my $compr = readFile($name); + ok length $compr ; + my $unc = Compress::Zlib::memGunzip($compr) ; + ok defined $unc ; + ok $buffer eq $unc ; + unlink $name ; +} + +{ + + # Check - MAX_WBITS + # ================= + + $hello = "Test test test test test"; + @hello = split('', $hello) ; + + ok (($x, $err) = deflateInit( -Bufsize => 1, -WindowBits => -MAX_WBITS() ) ) ; + ok $x ; + ok $err == Z_OK ; + + $Answer = ''; + foreach (@hello) + { + ($X, $status) = $x->deflate($_) ; + last unless $status == Z_OK ; + + $Answer .= $X ; + } + + ok $status == Z_OK ; + + ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; + $Answer .= $X ; + + + @Answer = split('', $Answer) ; + # Undocumented corner -- extra byte needed to get inflate to return + # Z_STREAM_END when done. + push @Answer, " " ; + + ok (($k, $err) = inflateInit(-Bufsize => 1, -WindowBits => -MAX_WBITS()) ) ; + ok $k ; + ok $err == Z_OK ; + + $GOT = ''; + foreach (@Answer) + { + ($Z, $status) = $k->inflate($_) ; + $GOT .= $Z ; + last if $status == Z_STREAM_END or $status != Z_OK ; + + } + + ok $status == Z_STREAM_END ; + ok $GOT eq $hello ; + +} + +{ + # inflateSync + + # create a deflate stream with flush points + + my $hello = "I am a HAL 9000 computer" x 2001 ; + my $goodbye = "Will I dream?" x 2010; + my ($err, $answer, $X, $status, $Answer); + + ok (($x, $err) = deflateInit() ) ; + ok $x ; + ok $err == Z_OK ; + + ($Answer, $status) = $x->deflate($hello) ; + ok $status == Z_OK ; + + # create a flush point + ok ((($X, $status) = $x->flush(Z_FULL_FLUSH))[1] == Z_OK ) ; + $Answer .= $X ; + + ($X, $status) = $x->deflate($goodbye) ; + ok $status == Z_OK ; + $Answer .= $X ; + + ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; + $Answer .= $X ; + + my ($first, @Answer) = split('', $Answer) ; + + my $k; + ok (($k, $err) = inflateInit()) ; + ok $k ; + ok $err == Z_OK ; + + ($Z, $status) = $k->inflate($first) ; + ok $status == Z_OK ; + + # skip to the first flush point. + while (@Answer) + { + my $byte = shift @Answer; + $status = $k->inflateSync($byte) ; + last unless $status == Z_DATA_ERROR; + + } + + ok $status == Z_OK; + + my $GOT = ''; + my $Z = ''; + foreach (@Answer) + { + my $Z = ''; + ($Z, $status) = $k->inflate($_) ; + $GOT .= $Z if defined $Z ; + # print "x $status\n"; + last if $status == Z_STREAM_END or $status != Z_OK ; + + } + + # zlib 1.0.9 returns Z_STREAM_END here, all others return Z_DATA_ERROR + ok $status == Z_DATA_ERROR || $status == Z_STREAM_END ; + ok $GOT eq $goodbye ; + + + # Check inflateSync leaves good data in buffer + $Answer =~ /^(.)(.*)$/ ; + my ($initial, $rest) = ($1, $2); + + + ok (($k, $err) = inflateInit()) ; + ok $k ; + ok $err == Z_OK ; + + ($Z, $status) = $k->inflate($initial) ; + ok $status == Z_OK ; + + $status = $k->inflateSync($rest) ; + ok $status == Z_OK; + + ($GOT, $status) = $k->inflate($rest) ; + + ok $status == Z_DATA_ERROR ; + ok $Z . $GOT eq $goodbye ; +} + +{ + # deflateParams + + my $hello = "I am a HAL 9000 computer" x 2001 ; + my $goodbye = "Will I dream?" x 2010; + my ($input, $err, $answer, $X, $status, $Answer); + + ok (($x, $err) = deflateInit(-Level => Z_BEST_COMPRESSION, + -Strategy => Z_DEFAULT_STRATEGY) ) ; + ok $x ; + ok $err == Z_OK ; + + ok $x->get_Level() == Z_BEST_COMPRESSION; + ok $x->get_Strategy() == Z_DEFAULT_STRATEGY; + + ($Answer, $status) = $x->deflate($hello) ; + ok $status == Z_OK ; + $input .= $hello; + + # error cases + eval { $x->deflateParams() }; + ok $@ =~ m#^Compress::Zlib::deflateParams needs Level and/or Strategy#; + + eval { $x->deflateParams(-Joe => 3) }; + ok $@ =~ /^Compress::Zlib::deflateStream::deflateParams: unknown key value\(s\) Joe at/ + or print "# $@\n" ; + + ok $x->get_Level() == Z_BEST_COMPRESSION; + ok $x->get_Strategy() == Z_DEFAULT_STRATEGY; + + # change both Level & Strategy + $status = $x->deflateParams(-Level => Z_BEST_SPEED, -Strategy => Z_HUFFMAN_ONLY) ; + ok $status == Z_OK ; + + ok $x->get_Level() == Z_BEST_SPEED; + ok $x->get_Strategy() == Z_HUFFMAN_ONLY; + + ($X, $status) = $x->deflate($goodbye) ; + ok $status == Z_OK ; + $Answer .= $X ; + $input .= $goodbye; + + # change only Level + $status = $x->deflateParams(-Level => Z_NO_COMPRESSION) ; + ok $status == Z_OK ; + + ok $x->get_Level() == Z_NO_COMPRESSION; + ok $x->get_Strategy() == Z_HUFFMAN_ONLY; + + ($X, $status) = $x->deflate($goodbye) ; + ok $status == Z_OK ; + $Answer .= $X ; + $input .= $goodbye; + + # change only Strategy + $status = $x->deflateParams(-Strategy => Z_FILTERED) ; + ok $status == Z_OK ; + + ok $x->get_Level() == Z_NO_COMPRESSION; + ok $x->get_Strategy() == Z_FILTERED; + + ($X, $status) = $x->deflate($goodbye) ; + ok $status == Z_OK ; + $Answer .= $X ; + $input .= $goodbye; + + ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; + $Answer .= $X ; + + my ($first, @Answer) = split('', $Answer) ; + + my $k; + ok (($k, $err) = inflateInit()) ; + ok $k ; + ok $err == Z_OK ; + + ($Z, $status) = $k->inflate($Answer) ; + + ok $status == Z_STREAM_END + or print "# status $status\n"; + ok $Z eq $input ; +} + +{ + # error cases + + eval { deflateInit(-Level) }; + like $@, '/^Compress::Zlib::deflateInit: Expected even number of parameters, got 1/'; + + eval { inflateInit(-Level) }; + like $@, '/^Compress::Zlib::inflateInit: Expected even number of parameters, got 1/'; + + eval { deflateInit(-Joe => 1) }; + ok $@ =~ /^Compress::Zlib::deflateInit: unknown key value\(s\) Joe at/; + + eval { inflateInit(-Joe => 1) }; + ok $@ =~ /^Compress::Zlib::inflateInit: unknown key value\(s\) Joe at/; + + eval { deflateInit(-Bufsize => 0) }; + ok $@ =~ /^.*?: Bufsize must be >= 1, you specified 0 at/; + + eval { inflateInit(-Bufsize => 0) }; + ok $@ =~ /^.*?: Bufsize must be >= 1, you specified 0 at/; + + eval { deflateInit(-Bufsize => -1) }; + #ok $@ =~ /^.*?: Bufsize must be >= 1, you specified -1 at/; + ok $@ =~ /^Compress::Zlib::deflateInit: Parameter 'Bufsize' must be an unsigned int, got '-1'/; + + eval { inflateInit(-Bufsize => -1) }; + ok $@ =~ /^Compress::Zlib::inflateInit: Parameter 'Bufsize' must be an unsigned int, got '-1'/; + + eval { deflateInit(-Bufsize => "xxx") }; + ok $@ =~ /^Compress::Zlib::deflateInit: Parameter 'Bufsize' must be an unsigned int, got 'xxx'/; + + eval { inflateInit(-Bufsize => "xxx") }; + ok $@ =~ /^Compress::Zlib::inflateInit: Parameter 'Bufsize' must be an unsigned int, got 'xxx'/; + + eval { gzopen([], 0) ; } ; + ok $@ =~ /^gzopen: file parameter is not a filehandle or filename at/ + or print "# $@\n" ; + + my $x = Symbol::gensym() ; + eval { gzopen($x, 0) ; } ; + ok $@ =~ /^gzopen: file parameter is not a filehandle or filename at/ + or print "# $@\n" ; + +} + +if ($] >= 5.005) +{ + # test inflate with a substr + + ok my $x = deflateInit() ; + + ok ((my ($X, $status) = $x->deflate($contents))[1] == Z_OK) ; + + my $Y = $X ; + + + + ok ((($X, $status) = $x->flush() )[1] == Z_OK ) ; + $Y .= $X ; + + my $append = "Appended" ; + $Y .= $append ; + + ok $k = inflateInit() ; + + #($Z, $status) = $k->inflate(substr($Y, 0, -1)) ; + ($Z, $status) = $k->inflate(substr($Y, 0)) ; + + ok $status == Z_STREAM_END ; + ok $contents eq $Z ; + is $Y, $append; + +} + +if ($] >= 5.005) +{ + # deflate/inflate in scalar context + + ok my $x = deflateInit() ; + + my $X = $x->deflate($contents); + + my $Y = $X ; + + + + $X = $x->flush(); + $Y .= $X ; + + my $append = "Appended" ; + $Y .= $append ; + + ok $k = inflateInit() ; + + #$Z = $k->inflate(substr($Y, 0, -1)) ; + $Z = $k->inflate(substr($Y, 0)) ; + + ok $contents eq $Z ; + is $Y, $append; + +} + +{ + title 'CRC32' ; + + my $data = 'ZgRNtjgSUW'; # CRC32 of this data should have the high bit set + my $expected_crc = 0xCF707A2B ; # 3480255019 + my $crc = crc32($data) ; + is $crc, $expected_crc; +} + +{ + title 'Adler32' ; + + my $data = 'lpscOVsAJiUfNComkOfWYBcPhHZ[bT'; # adler of this data should have the high bit set + my $expected_crc = 0xAAD60AC7 ; # 2866154183 + my $crc = adler32($data) ; + is $crc, $expected_crc; +} + +{ + # memGunzip - input > 4K + + my $contents = '' ; + foreach (1 .. 20000) + { $contents .= chr int rand 256 } + + ok my $compressed = Compress::Zlib::memGzip(\$contents) ; + + ok length $compressed > 4096 ; + ok my $out = Compress::Zlib::memGunzip(\$compressed) ; + + ok $contents eq $out ; + is length $out, length $contents ; + + +} + + +{ + # memGunzip Header Corruption Tests + + my $string = <<EOM; +some text +EOM + + my $good ; + ok my $x = new IO::Compress::Gzip \$good, Append => 1, -HeaderCRC => 1 ; + ok $x->write($string) ; + ok $x->close ; + + { + title "Header Corruption - Fingerprint wrong 1st byte" ; + my $buffer = $good ; + substr($buffer, 0, 1) = 'x' ; + + ok ! Compress::Zlib::memGunzip(\$buffer) ; + } + + { + title "Header Corruption - Fingerprint wrong 2nd byte" ; + my $buffer = $good ; + substr($buffer, 1, 1) = "\xFF" ; + + ok ! Compress::Zlib::memGunzip(\$buffer) ; + } + + { + title "Header Corruption - CM not 8"; + my $buffer = $good ; + substr($buffer, 2, 1) = 'x' ; + + ok ! Compress::Zlib::memGunzip(\$buffer) ; + } + + { + title "Header Corruption - Use of Reserved Flags"; + my $buffer = $good ; + substr($buffer, 3, 1) = "\xff"; + + ok ! Compress::Zlib::memGunzip(\$buffer) ; + } + +} + +for my $index ( GZIP_MIN_HEADER_SIZE + 1 .. GZIP_MIN_HEADER_SIZE + GZIP_FEXTRA_HEADER_SIZE + 1) +{ + title "Header Corruption - Truncated in Extra"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, Append => 1, -HeaderCRC => 1, Strict => 0, + -ExtraField => "hello" x 10 ; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + + ok ! Compress::Zlib::memGunzip(\$truncated) ; + + +} + +my $Name = "fred" ; +for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Name) -1) +{ + title "Header Corruption - Truncated in Name"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, Append => 1, -Name => $Name; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + + ok ! Compress::Zlib::memGunzip(\$truncated) ; +} + +my $Comment = "comment" ; +for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Comment) -1) +{ + title "Header Corruption - Truncated in Comment"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -Comment => $Comment; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + ok ! Compress::Zlib::memGunzip(\$truncated) ; +} + +for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + GZIP_FHCRC_SIZE -1) +{ + title "Header Corruption - Truncated in CRC"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + + ok ! Compress::Zlib::memGunzip(\$truncated) ; +} + +{ + title "memGunzip can cope with a gzip header with all possible fields"; + my $string = <<EOM; +some text +EOM + + my $buffer ; + ok my $x = new IO::Compress::Gzip \$buffer, + -Append => 1, + -Strict => 0, + -HeaderCRC => 1, + -Name => "Fred", + -ExtraField => "Extra", + -Comment => 'Comment'; + ok $x->write($string) ; + ok $x->close ; + + ok defined $buffer ; + + ok my $got = Compress::Zlib::memGunzip($buffer) + or diag "gzerrno is $gzerrno" ; + is $got, $string ; +} + + +{ + # Trailer Corruption tests + + my $string = <<EOM; +some text +EOM + + my $good ; + ok my $x = new IO::Compress::Gzip \$good, Append => 1 ; + ok $x->write($string) ; + ok $x->close ; + + foreach my $trim (-8 .. -1) + { + my $got = $trim + 8 ; + title "Trailer Corruption - Trailer truncated to $got bytes" ; + my $buffer = $good ; + + substr($buffer, $trim) = ''; + + ok my $u = Compress::Zlib::memGunzip(\$buffer) ; + ok $u eq $string; + + } + + { + title "Trailer Corruption - Length Wrong, CRC Correct" ; + my $buffer = $good ; + substr($buffer, -4, 4) = pack('V', 1234); + + ok ! Compress::Zlib::memGunzip(\$buffer) ; + } + + { + title "Trailer Corruption - Length Wrong, CRC Wrong" ; + my $buffer = $good ; + substr($buffer, -4, 4) = pack('V', 1234); + substr($buffer, -8, 4) = pack('V', 1234); + + ok ! Compress::Zlib::memGunzip(\$buffer) ; + + } +} + + + + diff --git a/ext/Compress/Zlib/t/04def.t b/ext/Compress/Zlib/t/04def.t new file mode 100644 index 0000000000..b0416e8924 --- /dev/null +++ b/ext/Compress/Zlib/t/04def.t @@ -0,0 +1,1550 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN +{ + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 1775 + $extra ; + + use_ok('Compress::Zlib', 2) ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; + + use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; + use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; + +} + +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + + +our ($UncompressClass); + + +sub myGZreadFile +{ + my $filename = shift ; + my $init = shift ; + + + my $fil = new $UncompressClass $filename, + -Strict => 1, + -Append => 1 + ; + + my $data = ''; + $data = $init if defined $init ; + 1 while $fil->read($data) > 0; + + $fil->close ; + return $data ; +} + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + + + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate') +{ + + title "Testing $CompressClass"; + + # Buffer not writable + eval qq[\$a = new $CompressClass(\\1) ;] ; + like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ; + + my $out = "" ; + eval qq[\$a = new $CompressClass \$out ;] ; + like $@, mkEvalErr("^$CompressClass: output filename is undef or null string"); + + $out = undef ; + eval qq[\$a = new $CompressClass \$out ;] ; + like $@, mkEvalErr("^$CompressClass: output filename is undef or null string"); + + my $x ; + my $gz = new $CompressClass(\$x); + + foreach my $name (qw(read readline getc)) + { + eval " \$gz->$name() " ; + like $@, mkEvalErr("^$name Not Available: File opened only for output"); + } + + eval ' $gz->write({})' ; + like $@, mkEvalErr("^${CompressClass}::write: not a scalar reference"); + #like $@, mkEvalErr("^${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref"); + + eval ' $gz->syswrite("abc", 1, 5)' ; + like $@, mkEvalErr("^${CompressClass}::write: offset outside string"); + + eval ' $gz->syswrite("abc", 1, -4)' ; + like $@, mkEvalErr("^${CompressClass}::write: offset outside string"); +} + + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $UnError = getErrorRef($UncompressClass); + + title "Testing $UncompressClass"; + + my $out = "" ; + eval qq[\$a = new $UncompressClass \$out ;] ; + like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string"); + + $out = undef ; + eval qq[\$a = new $UncompressClass \$out ;] ; + like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string"); + + my $lex = new LexFile my $name ; + + ok ! -e $name, " $name does not exist"; + + eval qq[\$a = new $UncompressClass "$name" ;] ; + is $$UnError, "input file '$name' does not exist"; + + my $gc ; + my $guz = new $CompressClass(\$gc); + $guz->write("abc") ; + $guz->close(); + + my $x ; + my $gz = new $UncompressClass(\$gc); + + foreach my $name (qw(print printf write)) + { + eval " \$gz->$name() " ; + like $@, mkEvalErr("^$name Not Available: File opened only for intput"); + } + +} + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($CompressClass); + my $ErrorUnc = getErrorRef($UncompressClass); + + + title "Testing $CompressClass and $UncompressClass"; + + { + my ($a, $x, @x) = ("","","") ; + + # Buffer not a scalar reference + eval qq[\$a = new $CompressClass \\\@x ;] ; + like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref"); + + # Buffer not a scalar reference + eval qq[\$a = new $UncompressClass \\\@x ;] ; + like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref"); + } + + foreach my $Type ( $CompressClass, $UncompressClass) + { + # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate + + my ($a, $x, @x) = ("","","") ; + + # Odd number of parameters + eval qq[\$a = new $Type "abc", -Output ] ; + like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1"); + + # Unknown parameter + eval qq[\$a = new $Type "anc", -Fred => 123 ;] ; + like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred"); + + # no in or out param + eval qq[\$a = new $Type ;] ; + like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter"); + + } + + + { + # write a very simple compressed file + # and read back + #======================================== + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + my $x ; + ok $x = new $CompressClass $name ; + + ok $x->write($hello), "write" ; + ok $x->flush(Z_FINISH), "flush"; + ok $x->close, "close" ; + } + + { + my $uncomp; + ok my $x = new $UncompressClass $name, -Append => 1 ; + + my $len ; + 1 while ($len = $x->read($uncomp)) > 0 ; + + ok $x->close ; + is $hello, $uncomp ; + } + } + + { + # write a very simple compressed file + # and read back + #======================================== + + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + my $x ; + ok $x = new $CompressClass $name ; + + is $x->write(''), 0, "Write empty string is ok"; + is $x->write(undef), 0, "Write undef is ok"; + ok $x->write($hello), "Write ok" ; + ok $x->close, "Close ok" ; + } + + { + my $uncomp; + my $x = new $UncompressClass $name ; + ok $x, "creates $UncompressClass $name" ; + + my $data = ''; + $data .= $uncomp while $x->read($uncomp) > 0 ; + + ok $x->close, "close ok" ; + is $data, $uncomp,"expected output" ; + } + } + + + { + # write a very simple file with using an IO filehandle + # and read back + #======================================== + + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + my $fh = new IO::File ">$name" ; + ok $fh, "opened file $name ok"; + my $x = new $CompressClass $fh ; + ok $x, " created $CompressClass $fh" ; + + is $x->fileno(), fileno($fh), "fileno match" ; + is $x->write(''), 0, "Write empty string is ok"; + is $x->write(undef), 0, "Write undef is ok"; + ok $x->write($hello), "write ok" ; + ok $x->flush(), "flush"; + ok $x->close,"close" ; + $fh->close() ; + } + + my $uncomp; + { + my $x ; + ok my $fh1 = new IO::File "<$name" ; + ok $x = new $UncompressClass $fh1, -Append => 1 ; + ok $x->fileno() == fileno $fh1 ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close ; + } + + ok $hello eq $uncomp ; + } + + { + # write a very simple file with using a glob filehandle + # and read back + #======================================== + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + title "$CompressClass: Input from typeglob filehandle"; + ok open FH, ">$name" ; + + my $x = new $CompressClass *FH ; + ok $x, " create $CompressClass" ; + + is $x->fileno(), fileno(*FH), " fileno" ; + is $x->write(''), 0, " Write empty string is ok"; + is $x->write(undef), 0, " Write undef is ok"; + ok $x->write($hello), " Write ok" ; + ok $x->flush(), " Flush"; + ok $x->close, " Close" ; + close FH; + } + + my $uncomp; + { + title "$UncompressClass: Input from typeglob filehandle, append output"; + my $x ; + ok open FH, "<$name" ; + ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0 ; + is $x->fileno(), fileno FH, " fileno ok" ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close, " close" ; + } + + is $uncomp, $hello, " expected output" ; + } + + { + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + title "Outout to stdout via '-'" ; + + open(SAVEOUT, ">&STDOUT"); + my $dummy = fileno SAVEOUT; + open STDOUT, ">$name" ; + + my $x = new $CompressClass '-' ; + $x->write($hello); + $x->close; + + open(STDOUT, ">&SAVEOUT"); + + ok 1, " wrote to stdout" ; + } + + { + title "Input from stdin via filename '-'"; + + my $x ; + my $uncomp ; + my $stdinFileno = fileno(STDIN); + # open below doesn't return 1 sometines on XP + open(SAVEIN, "<&STDIN"); + ok open(STDIN, "<$name"), " redirect STDIN"; + my $dummy = fileno SAVEIN; + $x = new $UncompressClass '-'; + ok $x, " created object" ; + is $x->fileno(), $stdinFileno, " fileno ok" ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close, " close" ; + open(STDIN, "<&SAVEIN"); + is $hello, $uncomp, " expected output" ; + } + } + + { + # write a compressed file to memory + # and read back + #======================================== + + my $name = "test.gz" ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + my $buffer ; + { + my $x ; + ok $x = new $CompressClass(\$buffer) ; + + ok ! defined $x->fileno() ; + is $x->write(''), 0, "Write empty string is ok"; + is $x->write(undef), 0, "Write undef is ok"; + ok $x->write($hello) ; + ok $x->flush(); + ok $x->close ; + + writeFile($name, $buffer) ; + #is anyUncompress(\$buffer), $hello, " any ok"; + } + + my $keep = $buffer ; + my $uncomp; + { + my $x ; + ok $x = new $UncompressClass(\$buffer, Append => 1) ; + + ok ! defined $x->fileno() ; + 1 while $x->read($uncomp) > 0 ; + + ok $x->close ; + } + + is $uncomp, $hello ; + ok $buffer eq $keep ; + } + + if ($CompressClass ne 'RawDeflate') + { + # write empty file + #======================================== + + my $buffer = ''; + { + my $x ; + ok $x = new $CompressClass(\$buffer) ; + ok $x->close ; + + } + + my $keep = $buffer ; + my $uncomp= ''; + { + my $x ; + ok $x = new $UncompressClass(\$buffer, Append => 1) ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close ; + } + + ok $uncomp eq '' ; + ok $buffer eq $keep ; + + } + + { + # write a larger file + #======================================== + + + my $lex = new LexFile my $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + my $input = '' ; + my $contents = '' ; + + { + my $x = new $CompressClass $name ; + ok $x, " created $CompressClass object"; + + ok $x->write($hello), " write ok" ; + $input .= $hello ; + ok $x->write("another line"), " write ok" ; + $input .= "another line" ; + # all characters + foreach (0 .. 255) + { $contents .= chr int $_ } + # generate a long random string + foreach (1 .. 5000) + { $contents .= chr int rand 256 } + + ok $x->write($contents), " write ok" ; + $input .= $contents ; + ok $x->close, " close ok" ; + } + + ok myGZreadFile($name) eq $input ; + my $x = readFile($name) ; + #print "length " . length($x) . " \n"; + } + + { + # embed a compressed file in another file + #================================ + + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + my $header = "header info\n" ; + my $trailer = "trailer data\n" ; + + { + my $fh ; + ok $fh = new IO::File ">$name" ; + print $fh $header ; + my $x ; + ok $x = new $CompressClass $fh, + -AutoClose => 0 ; + + ok $x->binmode(); + ok $x->write($hello) ; + ok $x->close ; + print $fh $trailer ; + $fh->close() ; + } + + my ($fil, $uncomp) ; + my $fh1 ; + ok $fh1 = new IO::File "<$name" ; + # skip leading junk + my $line = <$fh1> ; + ok $line eq $header ; + + ok my $x = new $UncompressClass $fh1 ; + ok $x->binmode(); + my $got = $x->read($uncomp); + + ok $uncomp eq $hello ; + my $rest ; + read($fh1, $rest, 5000); + is ${ $x->trailingData() } . $rest, $trailer ; + #print ${ $x->trailingData() } . $rest ; + + } + + { + # Write + # these tests come almost 100% from IO::String + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $io = $CompressClass->new($name); + + is $io->tell(), 0, " tell returns 0"; ; + + my $heisan = "Heisan\n"; + $io->print($heisan) ; + + ok ! $io->eof(), " ! eof"; + + is $io->tell(), length($heisan), " tell is " . length($heisan) ; + + $io->print("a", "b", "c"); + + { + local($\) = "\n"; + $io->print("d", "e"); + local($,) = ","; + $io->print("f", "g", "h"); + } + + { + local($\) ; + $io->print("D", "E"); + local($,) = "."; + $io->print("F", "G", "H"); + } + + my $foo = "1234567890"; + + is $io->syswrite($foo, length($foo)), length($foo), " syswrite ok" ; + if ( $[ < 5.6 ) + { is $io->syswrite($foo, length $foo), length $foo, " syswrite ok" } + else + { is $io->syswrite($foo), length $foo, " syswrite ok" } + is $io->syswrite($foo, length($foo)), length $foo, " syswrite ok"; + is $io->write($foo, length($foo), 5), 5, " write 5"; + is $io->write("xxx\n", 100, -1), 1, " write 1"; + + for (1..3) { + $io->printf("i(%d)", $_); + $io->printf("[%d]\n", $_); + } + $io->print("\n"); + + $io->close ; + + ok $io->eof(), " eof"; + + is myGZreadFile($name), "Heisan\nabcde\nf,g,h\nDEF.G.H" . + ("1234567890" x 3) . "67890\n" . + "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; + + + } + + { + # Read + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my %opts = () ; + %opts = (CRC32 => 1, Adler32 => 1) + if $CompressClass ne "IO::Compress::Gzip"; + my $iow = new $CompressClass $name, %opts; + $iow->print($str) ; + $iow->close ; + + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name ; + + ok ! $io->eof; + is $io->tell(), 0 ; + #my @lines = <$io>; + my @lines = $io->getlines(); + is @lines, 6 + or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; + is $lines[1], "of a paragraph\n" ; + is join('', @lines), $str ; + is $., 6; + is $io->tell(), length($str) ; + + ok $io->eof; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined($io->getline) || + defined($io->getc) || + $io->read($buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = $io->getline(); + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines(); + ok $io->eof; + ok @lines == 2 + or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# $lines[0]\n"; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (my $a = $io->getline()) { + push(@lines, $a); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 + or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + + eval { $io->read(1) } ; + like $@, mkErr("buffer parameter is read-only"); + + is $io->read($buf, 0), 0, "Requested 0 bytes" ; + + ok $io->read($buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok $io->sysread($buf, 3, 2) == 3 ; + ok $buf eq "Ths i" + or print "# [$buf]\n" ;; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + } + + { + # Read from non-compressed file + + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + writeFile($name, $str); + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name, -Transparent => 1 ; + + ok defined $io; + ok ! $io->eof; + ok $io->tell() == 0 ; + my @lines = $io->getlines(); + ok @lines == 6; + ok $lines[1] eq "of a paragraph\n" ; + ok join('', @lines) eq $str ; + ok $. == 6; + ok $io->tell() == length($str) ; + + ok $io->eof; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined($io->getline) || + defined($io->getc) || + $io->read($buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = $io->getline; + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 2 + or print "# exected 2 lines, got " . scalar(@lines) . "\n"; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# [$lines[0]]\n" ; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (my $a = $io->getline) { + push(@lines, $a); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + ok $io->read($buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok $io->sysread($buf, 3, 2) == 3 ; + ok $buf eq "Ths i"; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + + } + + { + # Vary the length parameter in a read + + my $str = <<EOT; +x +x +This is an example +of a paragraph + + +and a single line. + +EOT + $str = $str x 100 ; + + + foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) + { + foreach my $trans (0, 1) + { + foreach my $append (0, 1) + { + title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; + + my $name = "testz.gz" ; + my $lex = new LexFile $name ; + + if ($trans) { + writeFile($name, $str) ; + } + else { + my $iow = new $CompressClass $name; + $iow->print($str) ; + $iow->close ; + } + + + my $io = $UncompressClass->new($name, + -Append => $append, + -Transparent => $trans); + + my $buf; + + is $io->tell(), 0; + + if ($append) { + 1 while $io->read($buf, $bufsize) > 0; + } + else { + my $tmp ; + $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; + } + is length $buf, length $str; + ok $buf eq $str ; + ok ! $io->error() ; + ok $io->eof; + } + } + } + } + + foreach my $file (0, 1) + { + foreach my $trans (0, 1) + { + title "seek tests - file $file trans $trans" ; + + my $buffer ; + my $buff ; + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $first = "beginning" ; + my $last = "the end" ; + + if ($trans) + { + $buffer = $first . "\x00" x 10 . $last; + writeFile($name, $buffer); + } + else + { + my $output ; + if ($file) + { + $output = $name ; + } + else + { + $output = \$buffer; + } + + my $iow = new $CompressClass $output ; + $iow->print($first) ; + ok $iow->seek(5, SEEK_CUR) ; + ok $iow->tell() == length($first)+5; + ok $iow->seek(0, SEEK_CUR) ; + ok $iow->tell() == length($first)+5; + ok $iow->seek(length($first)+10, SEEK_SET) ; + ok $iow->tell() == length($first)+10; + + $iow->print($last) ; + $iow->close ; + } + + my $input ; + if ($file) + { + $input = $name ; + } + else + { + $input = \$buffer ; + } + + ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ; + + my $io = $UncompressClass->new($input, Strict => 1); + ok $io->seek(length($first), SEEK_CUR) ; + ok ! $io->eof; + is $io->tell(), length($first); + + ok $io->read($buff, 5) ; + is $buff, "\x00" x 5 ; + is $io->tell(), length($first) + 5; + + ok $io->seek(0, SEEK_CUR) ; + my $here = $io->tell() ; + is $here, length($first)+5; + + ok $io->seek($here+5, SEEK_SET) ; + is $io->tell(), $here+5 ; + ok $io->read($buff, 100) ; + ok $buff eq $last ; + ok $io->eof; + } + } + + { + title "seek error cases" ; + + my $b ; + my $a = new $CompressClass(\$b) ; + + ok ! $a->error() ; + eval { $a->seek(-1, 10) ; }; + like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter"); + + eval { $a->seek(-1, SEEK_END) ; }; + like $@, mkErr("^${CompressClass}::seek: cannot seek backwards"); + + $a->write("fred"); + $a->close ; + + + my $u = new $UncompressClass(\$b) ; + + eval { $u->seek(-1, 10) ; }; + like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter"); + + eval { $u->seek(-1, SEEK_END) ; }; + like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed"); + + eval { $u->seek(-1, SEEK_CUR) ; }; + like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards"); + } + + foreach my $fb (qw(filename buffer filehandle)) + { + foreach my $append (0, 1) + { + { + title "$CompressClass -- Append $append, Output to $fb" ; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $already = 'already'; + my $buffer = $already; + my $output; + + if ($fb eq 'buffer') + { $output = \$buffer } + elsif ($fb eq 'filename') + { + $output = $name ; + writeFile($name, $buffer); + } + elsif ($fb eq 'filehandle') + { + $output = new IO::File ">$name" ; + print $output $buffer; + } + + my $a = new $CompressClass($output, Append => $append) ; + ok $a, " Created $CompressClass"; + my $string = "appended"; + $a->write($string); + $a->close ; + + my $data ; + if ($fb eq 'buffer') + { + $data = $buffer; + } + else + { + $output->close + if $fb eq 'filehandle'; + $data = readFile($name); + } + + if ($append || $fb eq 'filehandle') + { + is substr($data, 0, length($already)), $already, " got prefix"; + substr($data, 0, length($already)) = ''; + } + + + my $uncomp; + my $x = new $UncompressClass(\$data, Append => 1) ; + ok $x, " created $UncompressClass"; + + my $len ; + 1 while ($len = $x->read($uncomp)) > 0 ; + + $x->close ; + is $uncomp, $string, ' Got uncompressed data' ; + + } + } + } + + foreach my $type (qw(buffer filename filehandle)) + { + title "$UncompressClass -- InputLength, read from $type"; + + my $compressed ; + my $string = "some data"; + my $c = new $CompressClass(\$compressed); + $c->write($string); + $c->close(); + + my $appended = "append"; + my $comp_len = length $compressed; + $compressed .= $appended; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + my $input ; + writeFile ($name, $compressed); + + if ($type eq 'buffer') + { + $input = \$compressed; + } + if ($type eq 'filename') + { + $input = $name; + } + elsif ($type eq 'filehandle') + { + my $fh = new IO::File "<$name" ; + ok $fh, "opened file $name ok"; + $input = $fh ; + } + + my $x = new $UncompressClass($input, InputLength => $comp_len) ; + ok $x, " created $UncompressClass"; + + my $len ; + my $output; + $len = $x->read($output, 100); + is $len, length($string); + is $output, $string; + + if ($type eq 'filehandle') + { + my $rest ; + $input->read($rest, 1000); + is $rest, $appended; + } + + + } + + foreach my $append (0, 1) + { + title "$UncompressClass -- Append $append" ; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $string = "appended"; + my $compressed ; + my $c = new $CompressClass(\$compressed); + $c->write($string); + $c->close(); + + my $x = new $UncompressClass(\$compressed, Append => $append) ; + ok $x, " created $UncompressClass"; + + my $already = 'already'; + my $output = $already; + + my $len ; + $len = $x->read($output, 100); + is $len, length($string); + + $x->close ; + + if ($append) + { + is substr($output, 0, length($already)), $already, " got prefix"; + substr($output, 0, length($already)) = ''; + } + is $output, $string, ' Got uncompressed data' ; + } + + + foreach my $file (0, 1) + { + foreach my $trans (0, 1) + { + title "ungetc, File $file, Transparent $trans" ; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $string = 'abcdeABCDE'; + my $b ; + if ($trans) + { + $b = $string ; + } + else + { + my $a = new $CompressClass(\$b) ; + $a->write($string); + $a->close ; + } + + my $from ; + if ($file) + { + writeFile($name, $b); + $from = $name ; + } + else + { + $from = \$b ; + } + + my $u = $UncompressClass->new($from, Transparent => 1) ; + my $first; + my $buff ; + + # do an ungetc before reading + $u->ungetc("X"); + $first = $u->getc(); + is $first, 'X'; + + $first = $u->getc(); + is $first, substr($string, 0,1); + $u->ungetc($first); + $first = $u->getc(); + is $first, substr($string, 0,1); + $u->ungetc($first); + + is $u->read($buff, 5), 5 ; + is $buff, substr($string, 0, 5); + + $u->ungetc($buff) ; + is $u->read($buff, length($string)), length($string) ; + is $buff, $string; + + ok $u->eof() ; + + my $extra = 'extra'; + $u->ungetc($extra); + ok ! $u->eof(); + is $u->read($buff), length($extra) ; + is $buff, $extra; + + ok $u->eof() ; + + $u->close(); + + } + } + + { + title "inflateSync on plain file"; + + my $hello = "I am a HAL 9000 computer" x 2001 ; + + my ($k, $err) = new $UncompressClass(\$hello, Transparent => 1); + ok $k ; + cmp_ok $err, '==', Z_OK ; + + # Skip to the flush point -- no-op for plain file + my $status = $k->inflateSync(); + is $status, 1 + or diag $k->error() ; + + my $rest; + is $k->read($rest, length($hello)), length($hello) + or diag $k->error() ; + ok $rest eq $hello ; + + ok $k->close(); + } + + { + title "inflateSync for real"; + + # create a deflate stream with flush points + + my $hello = "I am a HAL 9000 computer" x 2001 ; + my $goodbye = "Will I dream?" x 2010; + my ($x, $err, $answer, $X, $Z, $status); + my $Answer ; + + ok ($x = new $CompressClass(\$Answer)); + ok $x ; + + is $x->write($hello), length($hello); + + # create a flush point + ok $x->flush(Z_FULL_FLUSH) ; + + is $x->write($goodbye), length($goodbye); + + ok $x->close() ; + + my $k; + ($k, $err) = new $UncompressClass(\$Answer, BlockSize => 1); + ok $k ; + cmp_ok $err, '==', Z_OK ; + + my $initial; + is $k->read($initial, 1), 1 ; + is $initial, substr($hello, 0, 1); + + # Skip to the flush point + $status = $k->inflateSync(); + is $status, 1 + or diag $k->error() ; + + my $rest; + is $k->read($rest, length($hello) + length($goodbye)), + length($goodbye) + or diag $k->error() ; + ok $rest eq $goodbye ; + + ok $k->close(); + } + + { + title "inflateSync no FLUSH point"; + + # create a deflate stream with flush points + + my $hello = "I am a HAL 9000 computer" x 2001 ; + my ($x, $err, $answer, $X, $Z, $status); + my $Answer ; + + ok ($x = new $CompressClass(\$Answer)); + ok $x ; + + is $x->write($hello), length($hello); + + ok $x->close() ; + + my $k; + ($k, $err) = new $UncompressClass(\$Answer, BlockSize => 1); + ok $k ; + cmp_ok $err, '==', Z_OK ; + + my $initial; + is $k->read($initial, 1), 1 ; + is $initial, substr($hello, 0, 1); + + # Skip to the flush point + $status = $k->inflateSync(); + is $status, 0 + or diag $k->error() ; + + ok $k->close(); + is $k->inflateSync(), 0 ; + } + + { + title "write tests - invalid data" ; + + #my $name1 = "test.gz" ; + #my $lex = new LexFile $name1 ; + my $Answer ; + + #ok ! -e $name1, " File $name1 does not exist"; + + my @data = ( + [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], + [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], + [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], + [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ], + [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ], + [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ], + #[ "not readable", 'xx' ], + # same filehandle twice, 'xx' + ) ; + + foreach my $data (@data) + { + my ($send, $get) = @$data ; + title "${CompressClass}::write( $send )"; + my $copy; + eval "\$copy = $send"; + my $x = new $CompressClass(\$Answer); + ok $x, " Created $CompressClass object"; + eval { $x->write($copy) } ; + #like $@, "/^$get/", " error - $get"; + like $@, "/not a scalar reference /", " error - not a scalar reference"; + } + +# @data = ( +# [ '[ $name1 ]', "input file '$name1' does not exist" ], +# #[ "not readable", 'xx' ], +# # same filehandle twice, 'xx' +# ) ; +# +# foreach my $data (@data) +# { +# my ($send, $get) = @$data ; +# title "${CompressClass}::write( $send )"; +# my $copy; +# eval "\$copy = $send"; +# my $x = new $CompressClass(\$Answer); +# ok $x, " Created $CompressClass object"; +# ok ! $x->write($copy), " write fails" ; +# like $$Error, "/^$get/", " error - $get"; +# } + + #exit; + + } + + +# sub deepCopy +# { +# if (! ref $_[0] || ref $_[0] eq 'SCALAR') +# { +# return $_[0] ; +# } +# +# if (ref $_[0] eq 'ARRAY') +# { +# my @a ; +# for my $x ( @{ $_[0] }) +# { +# push @a, deepCopy($x); +# } +# +# return \@a ; +# } +# +# croak "bad! $_[0]"; +# +# } +# +# sub deepSubst +# { +# #my $data = shift ; +# my $from = $_[1] ; +# my $to = $_[2] ; +# +# if (! ref $_[0]) +# { +# $_[0] = $to +# if $_[0] eq $from ; +# return ; +# +# } +# +# if (ref $_[0] eq 'SCALAR') +# { +# $_[0] = \$to +# if defined ${ $_[0] } && ${ $_[0] } eq $from ; +# return ; +# +# } +# +# if (ref $_[0] eq 'ARRAY') +# { +# for my $x ( @{ $_[0] }) +# { +# deepSubst($x, $from, $to); +# } +# return ; +# } +# #croak "bad! $_[0]"; +# } + +# { +# title "More write tests" ; +# +# my $file1 = "file1" ; +# my $file2 = "file2" ; +# my $file3 = "file3" ; +# my $lex = new LexFile $file1, $file2, $file3 ; +# +# writeFile($file1, "F1"); +# writeFile($file2, "F2"); +# writeFile($file3, "F3"); +# +# my @data = ( +# [ '""', "" ], +# [ 'undef', "" ], +# [ '"abcd"', "abcd" ], +# +# [ '\""', "" ], +# [ '\undef', "" ], +# [ '\"abcd"', "abcd" ], +# +# [ '[]', "" ], +# [ '[[]]', "" ], +# [ '[[[]]]', "" ], +# [ '[\""]', "" ], +# [ '[\undef]', "" ], +# [ '[\"abcd"]', "abcd" ], +# [ '[\"ab", \"cd"]', "abcd" ], +# [ '[[\"ab"], [\"cd"]]', "abcd" ], +# +# [ '$file1', $file1 ], +# [ '$fh2', "F2" ], +# [ '[$file1, \"abc"]', "F1abc"], +# [ '[\"a", $file1, \"bc"]', "aF1bc"], +# [ '[\"a", $fh1, \"bc"]', "aF1bc"], +# [ '[\"a", $fh1, \"bc", $file2]', "aF1bcF2"], +# [ '[\"a", $fh1, \"bc", $file2, $fh3]', "aF1bcF2F3"], +# ) ; +# +# +# foreach my $data (@data) +# { +# my ($send, $get) = @$data ; +# +# my $fh1 = new IO::File "< $file1" ; +# my $fh2 = new IO::File "< $file2" ; +# my $fh3 = new IO::File "< $file3" ; +# +# title "${CompressClass}::write( $send )"; +# my $copy; +# eval "\$copy = $send"; +# my $Answer ; +# my $x = new $CompressClass(\$Answer); +# ok $x, " Created $CompressClass object"; +# my $len = length $get; +# is $x->write($copy), length($get), " write $len bytes"; +# ok $x->close(), " close ok" ; +# +# is myGZreadFile(\$Answer), $get, " got expected output" ; +# cmp_ok $$Error, '==', 0, " no error"; +# +# +# } +# +# } +} + + + + + + diff --git a/ext/Compress/Zlib/t/04encoding.t b/ext/Compress/Zlib/t/04encoding.t deleted file mode 100644 index 9d6632155f..0000000000 --- a/ext/Compress/Zlib/t/04encoding.t +++ /dev/null @@ -1,120 +0,0 @@ - -use strict ; -use warnings ; - -BEGIN -{ - - eval { require Encode; Encode->import(); }; - - if ($@) { - print "1..0 # Skip: Encode is not available\n"; - #exit 0; - $::bomb_out = 1; - } -} - -exit 0 if $::bomb_out ; - -use Compress::Zlib ; -#use Encode; - -sub ok -{ - my ($no, $ok) = @_ ; - - #++ $total ; - #++ $totalBad unless $ok ; - - print "ok $no\n" if $ok ; - print "not ok $no\n" unless $ok ; -} - -sub readFile -{ - my ($filename) = @_ ; - my ($string) = '' ; - - open (F, "<$filename") - or die "Cannot open $filename: $!\n" ; - binmode(F); - while (<F>) - { $string .= $_ } - close F ; - $string ; -} - -print "1..15\n" ; - -# Check zlib_version and ZLIB_VERSION are the same. -ok(1, Compress::Zlib::zlib_version eq ZLIB_VERSION) ; - - -{ - # length of this string is 2 characters - my $s = "\x{df}\x{100}"; - - my $cs = Compress::Zlib::memGzip($s); - - # length stored at end of gzip file should be 4 - my ($crc, $len) = unpack ("VV", substr($cs, -8, 8)); - - ok(2, $len == 4); -} - -{ - # length of this string is 2 characters - my $s = "\x{df}\x{100}"; - - my $cs = Compress::Zlib::memGzip(Encode::encode_utf8($s)); - - # length stored at end of gzip file should be 4 - my ($crc, $len) = unpack ("VV", substr($cs, -8, 8)); - - ok(3, $len == 4); -} - -{ - my $s = "\x{df}\x{100}"; - my $s_copy = $s ; - - my $cs = compress($s); - my $ces = compress(Encode::encode_utf8($s_copy)); - - ok(4, $cs eq $ces); - - my $un = uncompress($cs); - ok(5, $un ne $s); - - $un = uncompress($ces); - ok(6, $un ne $s); - - $un = Encode::decode_utf8(uncompress($cs)); - ok(7, $un eq $s); - -} - -{ - my $name = "test.gz" ; - my $s = "\x{df}\x{100}"; - my $byte_len = length( Encode::encode_utf8($s) ); - my ($uncomp) ; - - ok(8, my $fil = gzopen($name, "wb")) ; - - ok(9, $fil->gzwrite($s) == $byte_len) ; - - ok(10, ! $fil->gzclose ) ; - - ok(11, $fil = gzopen($name, "rb") ) ; - - ok(12, $fil->gzread($uncomp) == $byte_len) ; - ok(13, length($uncomp) == $byte_len); - - ok(14, ! $fil->gzclose ) ; - - unlink $name ; - - ok(15, $s eq Encode::decode_utf8($uncomp)) ; - -} diff --git a/ext/Compress/Zlib/t/03examples.t b/ext/Compress/Zlib/t/05examples.t index af16043572..82b30d3fcf 100644 --- a/ext/Compress/Zlib/t/03examples.t +++ b/ext/Compress/Zlib/t/05examples.t @@ -1,103 +1,36 @@ -use strict ; -use warnings ; +use lib 't'; -use Compress::Zlib; - -my $count = 0 ; -sub ok -{ - my $ok = shift ; - - #++ $total ; - #++ $totalBad unless $ok ; - ++ $count; - - print "ok $count\n" if $ok ; - print "not ok $count\n" unless $ok ; - #printf "# Failed test at line %d\n", (caller)[2] unless $ok ; - - $ok; -} - -sub writeFile -{ - my($filename, @strings) = @_ ; - open (F, ">$filename") - or die "Cannot open $filename: $!\n" ; - binmode(F); - foreach (@strings) - { print F } - close F ; -} +use strict; +use warnings; +use bytes; -sub readFile -{ - my ($filename) = @_ ; - my ($string) = '' ; - - open (F, "<$filename") - or die "Cannot open $filename: $!\n" ; - binmode(F); - while (<F>) - { $string .= $_ } - close F ; - $string ; -} - -sub diag -{ - my $msg = shift ; - $msg =~ s/^/# /mg; - #$msg =~ s/\n+$//; - $msg .= "\n" unless $msg =~ /\n\Z/; - print $msg; -} - -sub check -{ - my $command = shift ; - my $expected = shift ; - - my $stderr = 'err.out'; - unlink $stderr; - - my $cmd = "$command 2>$stderr"; - my $stdout = `$cmd` ; - - my $aok = 1 ; - - $aok &= ok $? == 0 - or diag " exit status is $?" ; - - $aok &= ok readFile($stderr) eq '' - or diag "Stderr is: " . readFile($stderr); - - if (defined $expected ) { - $aok &= ok $stdout eq $expected - or diag "got content:\n". $stdout; - } - - if (! $aok) { - diag "Command line: $cmd"; - my ($file, $line) = (caller)[1,2]; - diag "Test called from $file, line $line"; - } +use Test::More ; +use ZlibTestUtils; +use Compress::Zlib; - unlink $stderr; +BEGIN +{ + plan(skip_all => "Examples needs Perl 5.005 or better - you have Perl $]" ) + if $] < 5.005 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 30 + $extra ; } - my $Inc = join " ", map qq["-I$_"] => @INC; $Inc = '"-MExtUtils::testlib"' - if ! $ENV{PERL_CORE} && eval "require ExtUtils::testlib;" ; + if ! $ENV{PERL_CORE} && eval " require ExtUtils::testlib; " ; -my $Perl = '' ; -$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; +my $Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; $Perl = qq["$Perl"] if $^O eq 'MSWin32' ; -$Perl = "$Perl -w $Inc" ; +$Perl = "$Perl $Inc -w" ; my $examples = $ENV{PERL_CORE} ? "../ext/Compress/Zlib/examples" : "./examples"; @@ -131,6 +64,8 @@ my $file2 = "hello2.gz" ; my $stderr = "err.out" ; unlink $stderr ; +unlink $file1, $file2 ; + my $gz = gzopen($file1, "wb"); $gz->gzwrite($hello1); $gz->gzclose(); @@ -139,22 +74,55 @@ $gz = gzopen($file2, "wb"); $gz->gzwrite($hello2); $gz->gzclose(); -print "1..16\n" ; +sub check +{ + my $command = shift ; + my $expected = shift ; + + my $stderr = 'err.out'; + unlink $stderr; + + my $cmd = "$command 2>$stderr"; + my $stdout = `$cmd` ; + + my $aok = 1 ; + $aok &= is $?, 0, " exit status is 0" ; + $aok &= is readFile($stderr), '', " no stderr" ; + + $aok &= is $stdout, $expected, " expected content is ok" + if defined $expected ; + + if (! $aok) { + diag "Command line: $cmd"; + my ($file, $line) = (caller)[1,2]; + diag "Test called from $file, line $line"; + } + + unlink $stderr; +} # gzcat # ##### -check "$Perl ${examples}/gzcat $file1 $file2", $hello1 . $hello2 ; +title "gzcat.zlib" ; +check "$Perl ${examples}/gzcat.zlib $file1 $file2 ", $hello1 . $hello2 ; + +title "gzcat - command line" ; +check "$Perl ${examples}/gzcat $file1 $file2", $hello1 . $hello2; + +title "gzcat - stdin" ; +check "$Perl ${examples}/gzcat <$file1 ", $hello1; + # gzgrep # ###### -check "$Perl ${examples}/gzgrep the $file1 $file2", +title "gzgrep"; +check "$Perl ${examples}/gzgrep the $file1 $file2", join('', grep(/the/, @hello1, @hello2)); - unlink $file1, $file2 ; @@ -165,24 +133,27 @@ unlink $file1, $file2 ; writeFile($file1, $hello1) ; writeFile($file2, $hello2) ; +title "filtdef" ; # there's no way to set binmode on backticks in Win32 so we won't use $a later -check "$Perl ${examples}/filtdef $file1 $file2"; ; - -check "$Perl ${examples}/filtdef $file1 $file2 | $Perl ${examples}/filtinf 2>$stderr", $hello1 . $hello2; +check "$Perl ${examples}/filtdef $file1 $file2" ; +title "filtdef | filtinf"; +check "$Perl ${examples}/filtdef $file1 $file2 | $Perl ${examples}/filtinf", + $hello1 . $hello2; # gzstream # ######## { + title "gzstream" ; writeFile($file1, $hello1) ; - check "$Perl ${examples}/gzstream <$file1 >$file2" ; - - check "$Perl ${examples}/gzcat $file2", $hello1; + check "$Perl ${examples}/gzstream <$file1 >$file2"; + title "gzcat" ; + check "$Perl ${examples}/gzcat $file2", $hello1 ; } - END { for ($file1, $file2, $stderr) { 1 while unlink $_ } ; } + diff --git a/ext/Compress/Zlib/t/05gzsetp.t b/ext/Compress/Zlib/t/05gzsetp.t deleted file mode 100644 index 79573d829b..0000000000 --- a/ext/Compress/Zlib/t/05gzsetp.t +++ /dev/null @@ -1,72 +0,0 @@ - - -use strict ; -use warnings ; - -use Compress::Zlib ; - -if (Compress::Zlib::ZLIB_VERNUM() < 0x1060 ) -{ - my $ver = Compress::Zlib::zlib_version(); - print "1..0 # gzsetparams needs zlib 1.0.6 or better. You have $ver\n"; - exit 0 ; -} - -sub ok -{ - my ($no, $ok) = @_ ; - - #++ $total ; - #++ $totalBad unless $ok ; - - print "ok $no\n" if $ok ; - print "not ok $no\n" unless $ok ; -} - -print "1..11\n" ; - -# Check zlib_version and ZLIB_VERSION are the same. -ok(1, Compress::Zlib::zlib_version eq ZLIB_VERSION) ; - - -{ - # gzsetparams - - my $hello = "I am a HAL 9000 computer" x 2001 ; - my $len_hello = length $hello ; - my $goodbye = "Will I dream?" x 2010; - my $len_goodbye = length $goodbye; - - my ($input, $err, $answer, $X, $status, $Answer); - - my $name = "test.gz" ; - unlink $name ; - ok(2, my $x = gzopen($name, "wb")) ; - - ok(3, $x->gzwrite($hello) == $len_hello) ; - $input .= $hello; - - # error cases - eval { $x->gzsetparams() }; - ok(4, $@ =~ /^Usage: Compress::Zlib::gzFile::gzsetparams\(file, level, strategy\) at/); - - # change both Level & Strategy - $status = $x->gzsetparams(Z_BEST_SPEED, Z_HUFFMAN_ONLY) ; - ok(5, $status == Z_OK) ; - - ok(6, $x->gzwrite($goodbye) == $len_goodbye) ; - $input .= $goodbye; - - ok(7, ! $x->gzclose ) ; - - ok(8, my $k = gzopen($name, "rb")) ; - - my $len = length $input ; - my $uncompressed; - ok(9, $k->gzread($uncompressed, $len) == $len) ; - - ok(10, $uncompressed eq $input ) ; - ok(11, ! $k->gzclose ) ; - unlink $name ; -} - diff --git a/ext/Compress/Zlib/t/06gzdopen.t b/ext/Compress/Zlib/t/06gzdopen.t deleted file mode 100644 index 59a0d4f423..0000000000 --- a/ext/Compress/Zlib/t/06gzdopen.t +++ /dev/null @@ -1,132 +0,0 @@ - - -use strict ; -use warnings ; - -use Compress::Zlib ; - -sub ok -{ - my ($no, $ok) = @_ ; - - #++ $total ; - #++ $totalBad unless $ok ; - - print "ok $no\n" if $ok ; - print "not ok $no\n" unless $ok ; -} - -sub readFile -{ - my ($filename) = @_ ; - my ($string) = '' ; - - open (F, "<$filename") - or die "Cannot open $filename: $!\n" ; - binmode(F); - while (<F>) - { $string .= $_ } - close F ; - $string ; -} - -my $hello = <<EOM ; -hello world -this is a test -EOM - -my $len = length $hello ; - - -print "1..23\n" ; - -# Check zlib_version and ZLIB_VERSION are the same. -ok(1, Compress::Zlib::zlib_version eq ZLIB_VERSION) ; - - -# gzip - filehandle tests -# ======================== - -{ - use IO::File ; - my $filename = "fh.gz" ; - my $hello = "hello, hello, I'm back again" ; - my $len = length $hello ; - - my $f = new IO::File ">$filename" ; - binmode $f ; # for OS/2 - - ok(2, $f) ; - - my $line_one = "first line\n" ; - print $f $line_one; - - ok(3, my $fil = gzopen($f, "wb")) ; - - ok(4, $fil->gzwrite($hello) == $len) ; - - ok(5, ! $fil->gzclose ) ; - - - ok(6, my $g = new IO::File "<$filename") ; - binmode $g ; # for OS/2 - - my $first ; - my $ret = read($g, $first, length($line_one)); - ok(7, $ret == length($line_one)); - - ok(8, $first eq $line_one) ; - - ok(9, $fil = gzopen($g, "rb") ) ; - my $uncomp; - ok(10, (my $x = $fil->gzread($uncomp)) == $len) ; - - ok(11, ! $fil->gzclose ) ; - - unlink $filename ; - - ok(12, $hello eq $uncomp) ; - -} - -{ - my $filename = "fh.gz" ; - my $hello = "hello, hello, I'm back again" ; - my $len = length $hello ; - my $uncomp; - local (*FH1) ; - local (*FH2) ; - - ok(13, open FH1, ">$filename") ; - binmode FH1; # for OS/2 - - my $line_one = "first line\n" ; - print FH1 $line_one; - - ok(14, my $fil = gzopen(\*FH1, "wb")) ; - - ok(15, $fil->gzwrite($hello) == $len) ; - - ok(16, ! $fil->gzclose ) ; - - - ok(17, my $g = open FH2, "<$filename") ; - binmode FH2; # for OS/2 - - my $first ; - my $ret = read(FH2, $first, length($line_one)); - ok(18, $ret == length($line_one)); - - ok(19, $first eq $line_one) ; - - ok(20, $fil = gzopen(*FH2, "rb") ) ; - ok(21, (my $x = $fil->gzread($uncomp)) == $len) ; - - ok(22, ! $fil->gzclose ) ; - - unlink $filename ; - - ok(23, $hello eq $uncomp) ; - -} - diff --git a/ext/Compress/Zlib/t/06gzsetp.t b/ext/Compress/Zlib/t/06gzsetp.t new file mode 100644 index 0000000000..7506c5a770 --- /dev/null +++ b/ext/Compress/Zlib/t/06gzsetp.t @@ -0,0 +1,135 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +use Compress::Zlib 2 ; + +use IO::Compress::Gzip ; +use IO::Uncompress::Gunzip ; + +use IO::Compress::Deflate ; +use IO::Uncompress::Inflate ; + +use IO::Compress::RawDeflate ; +use IO::Uncompress::RawInflate ; + +our ($extra); + + +BEGIN +{ + # use Test::NoWarnings, if available + $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; +} + +my $ver = Compress::Zlib::zlib_version(); +plan skip_all => "gzsetparams needs zlib 1.0.6 or better. You have $ver\n" + if ZLIB_VERNUM() < 0x1060 ; + +plan tests => 51 + $extra ; + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + +{ + # gzsetparams + title "Testing gzsetparams"; + + my $hello = "I am a HAL 9000 computer" x 2001 ; + my $len_hello = length $hello ; + my $goodbye = "Will I dream?" x 2010; + my $len_goodbye = length $goodbye; + + my ($input, $err, $answer, $X, $status, $Answer); + + my $name = "test.gz" ; + unlink $name ; + ok my $x = gzopen($name, "wb"); + + $input .= $hello; + is $x->gzwrite($hello), $len_hello, "gzwrite returned $len_hello" ; + + # Error cases + eval { $x->gzsetparams() }; + like $@, mkErr('^Usage: Compress::Zlib::gzFile::gzsetparams\(file, level, strategy\)'); + + # Change both Level & Strategy + $status = $x->gzsetparams(Z_BEST_SPEED, Z_HUFFMAN_ONLY) ; + cmp_ok $status, '==', Z_OK, "status is Z_OK"; + + $input .= $goodbye; + is $x->gzwrite($goodbye), $len_goodbye, "gzwrite returned $len_goodbye" ; + + ok ! $x->gzclose, "closed" ; + + ok my $k = gzopen($name, "rb") ; + + # calling gzsetparams on reading is not allowed. + $status = $k->gzsetparams(Z_BEST_SPEED, Z_HUFFMAN_ONLY) ; + cmp_ok $status, '==', Z_STREAM_ERROR, "status is Z_STREAM_ERROR" ; + + my $len = length $input ; + my $uncompressed; + is $len, $k->gzread($uncompressed, $len) ; + + ok $uncompressed eq $input ; + ok $k->gzeof ; + ok ! $k->gzclose ; + ok $k->gzeof ; + unlink $name; +} + + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + my $UncompressClass = getInverse($CompressClass); + + title "Testing $CompressClass"; + + + # deflateParams + + my $hello = "I am a HAL 9000 computer" x 2001 ; + my $len_hello = length $hello ; + my $goodbye = "Will I dream?" x 2010; + my $len_goodbye = length $goodbye; + + #my ($input, $err, $answer, $X, $status, $Answer); + my $compressed; + + ok my $x = new $CompressClass(\$compressed) ; + + my $input .= $hello; + is $x->write($hello), $len_hello ; + + # Change both Level & Strategy + ok $x->deflateParams(Z_BEST_SPEED, Z_HUFFMAN_ONLY); + + $input .= $goodbye; + is $x->write($goodbye), $len_goodbye ; + + ok $x->close ; + + ok my $k = new $UncompressClass(\$compressed); + + my $len = length $input ; + my $uncompressed; + is $k->read($uncompressed, $len), $len + or diag "$IO::Uncompress::Gunzip::GunzipError" ; + + ok $uncompressed eq $input ; + ok $k->eof ; + ok $k->close ; + ok $k->eof ; +} diff --git a/ext/Compress/Zlib/t/07bufsize.t b/ext/Compress/Zlib/t/07bufsize.t new file mode 100644 index 0000000000..0670c06876 --- /dev/null +++ b/ext/Compress/Zlib/t/07bufsize.t @@ -0,0 +1,101 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN +{ + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 288 + $extra ; + + use_ok('Compress::Zlib', 2) ; +} + + +my $hello = <<EOM ; +hello world +this is a test +EOM + +my $len = length $hello ; + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION ; + + +for my $i (1 .. 13) +{ + + print "#\n#Length $i\n#\n"; + + my $hello = "I am a HAL 9000 computer" x 2001; + my $tmp = $hello ; + + my @hello = (); + push @hello, $1 + while $tmp =~ s/^(.{$i})//; + push @hello, $tmp if length $tmp ; + + my ($err, $x, $X, $status); + + ok( ($x, $err) = new Compress::Zlib::Deflate (-AppendOutput => 1)); + ok $x ; + cmp_ok $err, '==', Z_OK, " status is Z_OK" ; + + ok ! defined $x->msg(), " no msg" ; + is $x->total_in(), 0, " total_in == 0" ; + is $x->total_out(), 0, " total_out == 0" ; + + my $out ; + foreach (@hello) + { + $status = $x->deflate($_, $out) ; + last unless $status == Z_OK ; + + } + cmp_ok $status, '==', Z_OK, " status is Z_OK" ; + + cmp_ok $x->flush($out), '==', Z_OK, " flush returned Z_OK" ; + + ok ! defined $x->msg(), " no msg" ; + is $x->total_in(), length $hello, " length total_in" ; + is $x->total_out(), length $out, " length total_out" ; + + my @Answer = (); + $tmp = $out; + push @Answer, $1 while $tmp =~ s/^(.{$i})//; + push @Answer, $tmp if length $tmp ; + + my $k; + ok(($k, $err) = new Compress::Zlib::Inflate( -AppendOutput => 1)); + ok $k ; + cmp_ok $err, '==', Z_OK, " status is Z_OK" ; + + ok ! defined $k->msg(), " no msg" ; + is $k->total_in(), 0, " total_in == 0" ; + is $k->total_out(), 0, " total_out == 0" ; + my $GOT = ''; + my $Z; + $Z = 1 ;#x 2000 ; + foreach (@Answer) + { + $status = $k->inflate($_, $GOT) ; + last if $status == Z_STREAM_END or $status != Z_OK ; + + } + + cmp_ok $status, '==', Z_STREAM_END, " status is Z_STREAM_END" ; + is $GOT, $hello, " got expected output" ; + ok ! defined $k->msg(), " no msg" ; + is $k->total_in(), length $out, " length total_in ok" ; + is $k->total_out(), length $hello, " length total_out ok" ; + +} diff --git a/ext/Compress/Zlib/t/08encoding.t b/ext/Compress/Zlib/t/08encoding.t new file mode 100644 index 0000000000..978212e807 --- /dev/null +++ b/ext/Compress/Zlib/t/08encoding.t @@ -0,0 +1,117 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN +{ + plan skip_all => "Encode is not available" + if $] < 5.006 ; + + eval { require Encode; Encode->import(); }; + + plan skip_all => "Encode is not available" + if $@ ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 16 + $extra ; + + use_ok('Compress::Zlib', 2); +} + + + + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + + +if(0) +{ + # length of this string is 2 characters + my $s = "\x{df}\x{100}"; + + my $cs = Compress::Zlib::memGzip($s); + + # length stored at end of gzip file should be 4 + my ($crc, $len) = unpack ("VV", substr($cs, -8, 8)); + + is $len, 4, "length is 4"; +} + +{ + title "memGzip" ; + # length of this string is 2 characters + my $s = "\x{df}\x{100}"; + + my $cs = Compress::Zlib::memGzip(Encode::encode_utf8($s)); + + # length stored at end of gzip file should be 4 + my ($crc, $len) = unpack ("VV", substr($cs, -8, 8)); + + is $len, 4, " length is 4"; +} + +{ + title "compress/uncompress"; + + my $s = "\x{df}\x{100}"; + my $s_copy = $s ; + + #my $cs = compress($s); + my $ces = compress(Encode::encode_utf8($s_copy)); + + ok $ces, " compressed ok" ; + + #is $s, $ces ; + + #my $un = uncompress($cs); + #is $un, $s; + + my $un = Encode::decode_utf8(uncompress($ces)); + #my $un = uncompress($ces); + is $un, $s, " decode_utf8 ok"; + + #$un = Encode::decode_utf8(uncompress($cs)); + #is $un, $s; + +} + +{ + title "gzopen" ; + + my $name = "test.gz" ; + my $s = "\x{df}\x{100}"; + my $byte_len = length( Encode::encode_utf8($s) ); + my ($uncomp) ; + + ok my $fil = gzopen($name, "wb"), " gzopen for write ok" ; + + is $fil->gzwrite(Encode::encode_utf8($s)), $byte_len, " wrote $byte_len bytes" ; + + ok ! $fil->gzclose, " gzclose ok" ; + + ok $fil = gzopen($name, "rb"), " gzopen for read ok" ; + + is $fil->gzread($uncomp), $byte_len, " read $byte_len bytes" ; + is length($uncomp), $byte_len, " uncompress is $byte_len bytes"; + + ok ! $fil->gzclose, "gzclose ok" ; + + unlink $name ; + + is $s, Encode::decode_utf8($uncomp), " decode_utf8 ok" ; + +} + +# Add tests that check that the module traps use of wide chars + diff --git a/ext/Compress/Zlib/t/09gziphdr.t b/ext/Compress/Zlib/t/09gziphdr.t new file mode 100644 index 0000000000..8abb70acea --- /dev/null +++ b/ext/Compress/Zlib/t/09gziphdr.t @@ -0,0 +1,916 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + + plan tests => 788 + $extra ; + + use_ok('Compress::Zlib', 2) ; + use_ok('Compress::Gzip::Constants') ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + +} + + + +# Check the Gzip Header Parameters +#======================================== + +my $ThisOS_code = $Compress::Zlib::gzip_os_code; + +my $name = "test.gz" ; +my $lex = new LexFile $name ; + +{ + title "Check Defaults"; + # Check Name defaults undef, no name, no comment + # and Time can be explicitly set. + + my $hdr = readHeaderInfo($name, -Time => 1234); + + is $hdr->{Time}, 1234; + ok ! defined $hdr->{Name}; + is $hdr->{MethodName}, 'Deflated'; + is $hdr->{ExtraFlags}, 0; + is $hdr->{MethodID}, Z_DEFLATED; + is $hdr->{OsID}, $ThisOS_code ; + ok ! defined $hdr->{Comment} ; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{HeaderCRC} ; + ok ! $hdr->{isMinimalHeader} ; +} + +{ + + title "Check name can be different from filename" ; + # Check Name can be different from filename + # Comment and Extra can be set + # Can specify a zero Time + + my $comment = "This is a Comment" ; + my $extra = "A little something extra" ; + my $aname = "a new name" ; + my $hdr = readHeaderInfo $name, + -Strict => 0, + -Name => $aname, + -Comment => $comment, + -ExtraField => $extra, + -Time => 0 ; + + ok $hdr->{Time} == 0; + ok $hdr->{Name} eq $aname; + ok $hdr->{MethodName} eq 'Deflated'; + ok $hdr->{MethodID} == 8; + is $hdr->{ExtraFlags}, 0; + ok $hdr->{Comment} eq $comment ; + is $hdr->{OsID}, $ThisOS_code ; + ok ! $hdr->{isMinimalHeader} ; + ok ! defined $hdr->{HeaderCRC} ; +} + +{ + title "Check Time defaults to now" ; + + # Check Time defaults to now + # and that can have empty name, comment and extrafield + my $before = time ; + my $hdr = readHeaderInfo $name, + -TextFlag => 1, + -Name => "", + -Comment => "", + -ExtraField => ""; + my $after = time ; + + ok $hdr->{Time} >= $before ; + ok $hdr->{Time} <= $after ; + + ok defined $hdr->{Name} ; + ok $hdr->{Name} eq ""; + ok defined $hdr->{Comment} ; + ok $hdr->{Comment} eq ""; + ok defined $hdr->{ExtraFieldRaw} ; + ok $hdr->{ExtraFieldRaw} eq ""; + is $hdr->{ExtraFlags}, 0; + + ok ! $hdr->{isMinimalHeader} ; + ok $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + is $hdr->{OsID}, $ThisOS_code ; + +} + +{ + title "can have null extrafield" ; + + my $before = time ; + my $hdr = readHeaderInfo $name, + -strict => 0, + -Name => "a", + -Comment => "b", + -ExtraField => "\x00"; + my $after = time ; + + ok $hdr->{Time} >= $before ; + ok $hdr->{Time} <= $after ; + ok $hdr->{Name} eq "a"; + ok $hdr->{Comment} eq "b"; + is $hdr->{ExtraFlags}, 0; + ok $hdr->{ExtraFieldRaw} eq "\x00"; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + is $hdr->{OsID}, $ThisOS_code ; + +} + +{ + title "can have undef name, comment, time and extrafield" ; + + my $hdr = readHeaderInfo $name, + -Name => undef, + -Comment => undef, + -ExtraField => undef, + -Time => undef; + + ok $hdr->{Time} == 0; + ok ! defined $hdr->{Name} ; + ok ! defined $hdr->{Comment} ; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + is $hdr->{OsID}, $ThisOS_code ; + +} + +{ + title "Check crchdr" ; + + my $hdr = readHeaderInfo $name, -HeaderCRC => 1; + + ok ! defined $hdr->{Name}; + is $hdr->{ExtraFlags}, 0; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok defined $hdr->{HeaderCRC} ; + is $hdr->{OsID}, $ThisOS_code ; +} + +{ + title "Check ExtraFlags" ; + + my $hdr = readHeaderInfo $name, -Level => Z_BEST_SPEED; + + ok ! defined $hdr->{Name}; + is $hdr->{ExtraFlags}, 2; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + + $hdr = readHeaderInfo $name, -Level => Z_BEST_COMPRESSION; + + ok ! defined $hdr->{Name}; + is $hdr->{ExtraFlags}, 4; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + + $hdr = readHeaderInfo $name, -Level => Z_BEST_COMPRESSION, + -ExtraFlags => 42; + + ok ! defined $hdr->{Name}; + is $hdr->{ExtraFlags}, 42; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok ! defined $hdr->{HeaderCRC} ; + + +} + +{ + title "OS Code" ; + + for my $code ( -1, undef, '', 'fred' ) + { + my $code_name = defined $code ? "'$code'" : 'undef'; + eval { new IO::Compress::Gzip $name, -OS_Code => $code } ; + like $@, mkErr("^IO::Compress::Gzip: Parameter 'OS_Code' must be an unsigned int, got $code_name"), + " Trap OS Code $code_name"; + } + + for my $code ( qw( 256 ) ) + { + ok ! new IO::Compress::Gzip($name, OS_Code => $code) ; + like $GzipError, "/^OS_Code must be between 0 and 255, got '$code'/", + " Trap OS Code $code"; + } + + for my $code ( qw(0 1 12 254 255) ) + { + my $hdr = readHeaderInfo $name, OS_Code => $code; + + is $hdr->{OsID}, $code, " Code is $code" ; + } + + + +} + +{ + title 'Check ExtraField'; + + my @tests = ( + [1, ['AB' => ''] => [['AB'=>'']] ], + [1, {'AB' => ''} => [['AB'=>'']] ], + [1, ['AB' => 'Fred'] => [['AB'=>'Fred']] ], + [1, {'AB' => 'Fred'} => [['AB'=>'Fred']] ], + [1, ['Xx' => '','AB' => 'Fred'] => [['Xx' => ''],['AB'=>'Fred']] ], + [1, ['Xx' => '','Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred']] ], + [1, ['Xx' => '', + 'Xx' => 'Fred', + 'Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred'], + ['Xx'=>'Fred']] ], + [1, [ ['Xx' => 'a'], + ['AB' => 'Fred'] ] => [['Xx' => 'a'],['AB'=>'Fred']] ], + [0, {'AB' => 'Fred', + 'Pq' => 'r', + "\x01\x02" => "\x03"} => [['AB'=>'Fred'], + ['Pq'=>'r'], + ["\x01\x02"=>"\x03"]] ], + [1, ['AB' => 'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE] => + [['AB'=>'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE]] ], + ); + + foreach my $test (@tests) { + my ($order, $input, $result) = @$test ; + ok my $x = new IO::Compress::Gzip $name, + -ExtraField => $input, + -HeaderCRC => 1 + or diag "GzipError is $GzipError" ; ; + my $string = "abcd" ; + ok $x->write($string) ; + ok $x->close ; + is GZreadFile($name), $string ; + + ok $x = new IO::Uncompress::Gunzip $name, + #-Strict => 1, + -ParseExtra => 1 + or diag "GunzipError is $GunzipError" ; ; + my $hdr = $x->getHeaderInfo(); + ok $hdr; + ok ! defined $hdr->{Name}; + ok ! defined $hdr->{Comment} ; + ok ! $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok defined $hdr->{HeaderCRC} ; + + ok defined $hdr->{ExtraFieldRaw} ; + ok defined $hdr->{ExtraField} ; + + my $extra = $hdr->{ExtraField} ; + + if ($order) { + eq_array $extra, $result + } else { + eq_set $extra, $result; + } + } + +} + +{ + title 'Write Invalid ExtraField'; + + my $prefix = 'Error with ExtraField Parameter: '; + my @tests = ( + [ sub{ "abc" } => "Not a scalar, array ref or hash ref"], + [ [ "a" ] => "Not even number of elements"], + [ [ "a" => "fred" ] => 'SubField ID not two chars long'], + [ [ "a\x00" => "fred" ] => 'SubField ID 2nd byte is 0x00'], + [ [ [ {}, "abc" ]] => "SubField ID is a reference"], + [ [ [ "ab", \1 ]] => "SubField Data is a reference"], + [ [ {"a" => "fred"} ] => "Not list of lists"], + [ [ ['ab'=>'x'],{"a" => "fred"} ] => "Not list of lists"], + [ [ ["aa"] ] => "SubField must have two parts"], + [ [ ["aa", "b", "c"] ] => "SubField must have two parts"], + [ [ ["ab" => 'x' x (GZIP_FEXTRA_SUBFIELD_MAX_SIZE + 1) ] ] + => "SubField Data too long"], + + [ { 'abc', 1 } => "SubField ID not two chars long"], + [ { \1 , "abc" } => "SubField ID not two chars long"], + [ { "ab", \1 } => "SubField Data is a reference"], + ); + + + + foreach my $test (@tests) { + my ($input, $string) = @$test ; + my $buffer ; + my $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input; + ok ! $x ; + like $GzipError, "/^$prefix$string/"; + + } + +} + +{ + # Corrupt ExtraField + + my @tests = ( + ["Sub-field truncated", + "Error with ExtraField Parameter: FEXTRA Body", + "Header Error: Truncated in FEXTRA Body Section", + ['a', undef, undef] ], + ["Length of field incorrect", + "Error with ExtraField Parameter: FEXTRA Body", + "Header Error: Truncated in FEXTRA Body Section", + ["ab", 255, "abc"] ], + ["Length of 2nd field incorrect", + "Error with ExtraField Parameter: FEXTRA Body", + "Header Error: Truncated in FEXTRA Body Section", + ["ab", 3, "abc"], ["de", 7, "x"] ], + ["Length of 2nd field incorrect", + "Error with ExtraField Parameter: SubField ID 2nd byte is 0x00", + "Header Error: Truncated in FEXTRA Body Section", + ["a\x00", 3, "abc"], ["de", 7, "x"] ], + ); + + foreach my $test (@tests) + { + my $name = shift @$test; + my $gzip_error = shift @$test; + my $gunzip_error = shift @$test; + + title "Read Corrupt ExtraField - $name" ; + + my $input = ''; + + for my $field (@$test) + { + my ($id, $len, $data) = @$field; + + $input .= $id if defined $id ; + $input .= pack("v", $len) if defined $len ; + $input .= $data if defined $data; + } + #hexDump(\$input); + + my $buffer ; + my $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input, Strict => 1; + + ok ! $x, " IO::Compress::Gzip fails"; + like $GzipError, "/^$gzip_error/", " $name"; + + foreach my $check (0, 1) + { + ok $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input, Strict => 0 + or diag "GzipError is $GzipError" ; ; + my $string = "abcd" ; + $x->write($string) ; + $x->close ; + is anyUncompress(\$buffer), $string ; + + $x = new IO::Uncompress::Gunzip \$buffer, Strict => 0, + ParseExtra => $check; + if ($check) { + ok ! $x ; + like $GunzipError, "/^$gunzip_error/"; + } + else { + ok $x ; + } + + } + } +} + + +{ + title 'Check Minimal'; + + ok my $x = new IO::Compress::Gzip $name, -Minimal => 1; + my $string = "abcd" ; + ok $x->write($string) ; + ok $x->close ; + is GZreadFile($name), $string ; + + ok $x = new IO::Uncompress::Gunzip $name ; + my $hdr = $x->getHeaderInfo(); + ok $hdr; + ok $hdr->{Time} == 0; + is $hdr->{ExtraFlags}, 0; + ok ! defined $hdr->{Name} ; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + is $hdr->{OsName}, 'Unknown' ; + is $hdr->{MethodName}, "Deflated"; + is $hdr->{Flags}, 0; + ok $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok $x->close ; +} + +{ + # Check Minimal + no comressed data + # This is the smallest possible gzip file (20 bytes) + + ok my $x = new IO::Compress::Gzip $name, -Minimal => 1; + ok $x->close ; + ok GZreadFile($name) eq '' ; + + ok $x = new IO::Uncompress::Gunzip $name, -Append => 1 ; + my $data ; + my $status = 1; + + $status = $x->read($data) + while $status > 0; + is $status, 0 ; + is $data, ''; + ok ! $x->error() ; + ok $x->eof() ; + + my $hdr = $x->getHeaderInfo(); + ok $hdr; + + ok defined $hdr->{ISIZE} ; + is $hdr->{ISIZE}, 0; + + ok defined $hdr->{CRC32} ; + is $hdr->{CRC32}, 0; + + is $hdr->{Time}, 0; + ok ! defined $hdr->{Name} ; + ok ! defined $hdr->{ExtraFieldRaw} ; + ok ! defined $hdr->{Comment} ; + is $hdr->{OsName}, 'Unknown' ; + is $hdr->{MethodName}, "Deflated"; + is $hdr->{Flags}, 0; + ok $hdr->{isMinimalHeader} ; + ok ! $hdr->{TextFlag} ; + ok $x->close ; +} + +{ + # Header Corruption Tests + + my $string = <<EOM; +some text +EOM + + my $good = ''; + ok my $x = new IO::Compress::Gzip \$good, -HeaderCRC => 1 ; + ok $x->write($string) ; + ok $x->close ; + + { + title "Header Corruption - Fingerprint wrong 1st byte" ; + my $buffer = $good ; + substr($buffer, 0, 1) = 'x' ; + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + ok $GunzipError =~ /Header Error: Bad Magic/; + } + + { + title "Header Corruption - Fingerprint wrong 2nd byte" ; + my $buffer = $good ; + substr($buffer, 1, 1) = "\xFF" ; + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + ok $GunzipError =~ /Header Error: Bad Magic/; + #print "$GunzipError\n"; + } + + { + title "Header Corruption - CM not 8"; + my $buffer = $good ; + substr($buffer, 2, 1) = 'x' ; + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + like $GunzipError, '/Header Error: Not Deflate \(CM is \d+\)/'; + } + + { + title "Header Corruption - Use of Reserved Flags"; + my $buffer = $good ; + substr($buffer, 3, 1) = "\xff"; + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + like $GunzipError, '/Header Error: Use of Reserved Bits in FLG field./'; + } + + { + title "Header Corruption - Fail HeaderCRC"; + my $buffer = $good ; + substr($buffer, 10, 1) = chr((ord(substr($buffer, 10, 1)) + 1) & 0xFF); + + ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0, Strict => 1 + or print "# $GunzipError\n"; + like $GunzipError, '/Header Error: CRC16 mismatch/' + #or diag "buffer length " . length($buffer); + or hexDump(\$good), hexDump(\$buffer); + } +} + +{ + title "ExtraField max raw size"; + my $x ; + my $store = "x" x GZIP_FEXTRA_MAX_SIZE ; + my $z = new IO::Compress::Gzip(\$x, ExtraField => $store, Strict => 0) ; + ok $z, "Created IO::Compress::Gzip object" ; + my $gunz = new IO::Uncompress::Gunzip \$x, Strict => 0; + ok $gunz, "Created IO::Uncompress::Gunzip object" ; + my $hdr = $gunz->getHeaderInfo(); + ok $hdr; + + is $hdr->{ExtraFieldRaw}, $store ; +} + +{ + title "Header Corruption - ExtraField too big"; + my $x; + ok ! new IO::Compress::Gzip(\$x, + -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ; + like $GzipError, '/Error with ExtraField Parameter: Too Large/'; +} + +{ + title "Header Corruption - Create Name with Illegal Chars"; + + my $x; + ok ! new IO::Compress::Gzip \$x, + -Name => "fred\x02" ; + like $GzipError, '/Non ISO 8859-1 Character found in Name/'; + + ok my $gz = new IO::Compress::Gzip \$x, + -Strict => 0, + -Name => "fred\x02" ; + ok $gz->close(); + + ok ! new IO::Uncompress::Gunzip \$x, + -Strict => 1; + + like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Name/'; + ok my $gunzip = new IO::Uncompress::Gunzip \$x, + -Strict => 0; + + my $hdr = $gunzip->getHeaderInfo() ; + + is $hdr->{Name}, "fred\x02"; + +} + +{ + title "Header Corruption - Null Chars in Name"; + my $x; + ok ! new IO::Compress::Gzip \$x, + -Name => "\x00" ; + like $GzipError, '/Null Character found in Name/'; + + ok ! new IO::Compress::Gzip \$x, + -Name => "abc\x00" ; + like $GzipError, '/Null Character found in Name/'; + + ok my $gz = new IO::Compress::Gzip \$x, + -Strict => 0, + -Name => "abc\x00de" ; + ok $gz->close() ; + ok my $gunzip = new IO::Uncompress::Gunzip \$x, + -Strict => 0; + + my $hdr = $gunzip->getHeaderInfo() ; + + is $hdr->{Name}, "abc"; + +} + +{ + title "Header Corruption - Create Comment with Illegal Chars"; + + my $x; + ok ! new IO::Compress::Gzip \$x, + -Comment => "fred\x02" ; + like $GzipError, '/Non ISO 8859-1 Character found in Comment/'; + + ok my $gz = new IO::Compress::Gzip \$x, + -Strict => 0, + -Comment => "fred\x02" ; + ok $gz->close(); + + ok ! new IO::Uncompress::Gunzip \$x, Strict => 1; + + like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Comment/'; + ok my $gunzip = new IO::Uncompress::Gunzip \$x, Strict => 0; + + my $hdr = $gunzip->getHeaderInfo() ; + + is $hdr->{Comment}, "fred\x02"; + +} + +{ + title "Header Corruption - Null Char in Comment"; + my $x; + ok ! new IO::Compress::Gzip \$x, + -Comment => "\x00" ; + like $GzipError, '/Null Character found in Comment/'; + + ok ! new IO::Compress::Gzip \$x, + -Comment => "abc\x00" ; + like $GzipError, '/Null Character found in Comment/'; + + ok my $gz = new IO::Compress::Gzip \$x, + -Strict => 0, + -Comment => "abc\x00de" ; + ok $gz->close() ; + ok my $gunzip = new IO::Uncompress::Gunzip \$x, + -Strict => 0; + + my $hdr = $gunzip->getHeaderInfo() ; + + is $hdr->{Comment}, "abc"; + +} + + +for my $index ( GZIP_MIN_HEADER_SIZE + 1 .. GZIP_MIN_HEADER_SIZE + GZIP_FEXTRA_HEADER_SIZE + 1) +{ + title "Header Corruption - Truncated in Extra"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1, Strict => 0, + -ExtraField => "hello" x 10 ; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + #my $name = "trunc.gz" ; + #my $lex = new LexFile $name ; + #writeFile($name, $truncated) ; + + #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; + my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; + ok ! $g + or print "# $g\n" ; + + like($GunzipError, '/^Header Error: Truncated in FEXTRA/'); + + +} + +my $Name = "fred" ; + my $truncated ; +for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Name) -1) +{ + title "Header Corruption - Truncated in Name"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -Name => $Name; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + + my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; + ok ! $g + or print "# $g\n" ; + + like $GunzipError, '/^Header Error: Truncated in FNAME Section/'; + +} + +my $Comment = "comment" ; +for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Comment) -1) +{ + title "Header Corruption - Truncated in Comment"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -Comment => $Comment; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + #my $name = "trunc.gz" ; + #my $lex = new LexFile $name ; + #writeFile($name, $truncated) ; + + #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; + my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; + ok ! $g + or print "# $g\n" ; + + like $GunzipError, '/^Header Error: Truncated in FCOMMENT Section/'; + +} + +for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + GZIP_FHCRC_SIZE -1) +{ + title "Header Corruption - Truncated in CRC"; + my $string = <<EOM; +some text +EOM + + my $truncated ; + ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1; + ok $x->write($string) ; + ok $x->close ; + + substr($truncated, $index) = '' ; + my $name = "trunc.gz" ; + my $lex = new LexFile $name ; + writeFile($name, $truncated) ; + + my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; + #my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; + ok ! $g + or print "# $g\n" ; + + like $GunzipError, '/^Header Error: Truncated in FHCRC Section/'; + +} + + +{ + # Trailer Corruption tests + + my $string = <<EOM; +some text +EOM + + my $good ; + { + ok my $x = new IO::Compress::Gzip \$good ; + ok $x->write($string) ; + ok $x->close ; + } + + writeFile($name, $good) ; + ok my $gunz = new IO::Uncompress::Gunzip $name, + -Strict => 1; + my $uncomp ; + 1 while $gunz->read($uncomp) > 0 ; + ok $gunz->close() ; + ok $uncomp eq $string + or print "# got [$uncomp] wanted [$string]\n";; + + foreach my $trim (-8 .. -1) + { + my $got = $trim + 8 ; + title "Trailer Corruption - Trailer truncated to $got bytes" ; + my $buffer = $good ; + my $expected_trailing = substr($good, -8, 8) ; + substr($expected_trailing, $trim) = ''; + + substr($buffer, $trim) = ''; + writeFile($name, $buffer) ; + + foreach my $strict (0, 1) + { + ok my $gunz = new IO::Uncompress::Gunzip $name, -Strict => $strict ; + my $uncomp ; + if ($strict) + { + ok $gunz->read($uncomp) < 0 ; + like $GunzipError, "/Trailer Error: trailer truncated. Expected 8 bytes, got $got/"; + } + else + { + ok $gunz->read($uncomp) > 0 ; + ok ! $GunzipError ; + my $expected = substr($buffer, - $got); + is ${ $gunz->trailingData() }, $expected_trailing; + } + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } + + { + title "Trailer Corruption - Length Wrong, CRC Correct" ; + my $buffer = $good ; + my $actual_len = unpack("V", substr($buffer, -4, 4)); + substr($buffer, -4, 4) = pack('V', $actual_len + 1); + writeFile($name, $buffer) ; + + foreach my $strict (0, 1) + { + ok my $gunz = new IO::Uncompress::Gunzip $name, + -Strict => $strict ; + my $uncomp ; + if ($strict) + { + ok $gunz->read($uncomp) < 0 ; + my $got_len = $actual_len + 1; + like $GunzipError, "/Trailer Error: ISIZE mismatch. Got $got_len, expected $actual_len/"; + } + else + { + ok $gunz->read($uncomp) > 0 ; + ok ! $GunzipError ; + #is $gunz->trailingData(), substr($buffer, - $got) ; + } + ok ! ${ $gunz->trailingData() } ; + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } + + { + title "Trailer Corruption - Length Correct, CRC Wrong" ; + my $buffer = $good ; + my $actual_crc = unpack("V", substr($buffer, -8, 4)); + substr($buffer, -8, 4) = pack('V', $actual_crc+1); + writeFile($name, $buffer) ; + + foreach my $strict (0, 1) + { + ok my $gunz = new IO::Uncompress::Gunzip $name, + -Strict => $strict ; + my $uncomp ; + if ($strict) + { + ok $gunz->read($uncomp) < 0 ; + like $GunzipError, '/Trailer Error: CRC mismatch/'; + } + else + { + ok $gunz->read($uncomp) > 0 ; + ok ! $GunzipError ; + } + ok ! ${ $gunz->trailingData() } ; + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } + + { + title "Trailer Corruption - Length Wrong, CRC Wrong" ; + my $buffer = $good ; + my $actual_len = unpack("V", substr($buffer, -4, 4)); + my $actual_crc = unpack("V", substr($buffer, -8, 4)); + substr($buffer, -4, 4) = pack('V', $actual_len+1); + substr($buffer, -8, 4) = pack('V', $actual_crc+1); + writeFile($name, $buffer) ; + + foreach my $strict (0, 1) + { + ok my $gunz = new IO::Uncompress::Gunzip $name, + -Strict => $strict ; + my $uncomp ; + if ($strict) + { + ok $gunz->read($uncomp) < 0 ; + like $GunzipError, '/Trailer Error: CRC mismatch/'; + } + else + { + ok $gunz->read($uncomp) > 0 ; + ok ! $GunzipError ; + } + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } +} + + + diff --git a/ext/Compress/Zlib/t/10defhdr.t b/ext/Compress/Zlib/t/10defhdr.t new file mode 100644 index 0000000000..9c109ec639 --- /dev/null +++ b/ext/Compress/Zlib/t/10defhdr.t @@ -0,0 +1,344 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 595 + $extra ; + + use_ok('Compress::Zlib', 2) ; + + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; + + use_ok('Compress::Zlib::FileConstants'); + +} + + +sub ReadHeaderInfo +{ + my $string = shift || '' ; + my %opts = @_ ; + + my $buffer ; + ok my $def = new IO::Compress::Deflate \$buffer, %opts ; + is $def->write($string), length($string) ; + ok $def->close ; + #print "ReadHeaderInfo\n"; hexDump(\$buffer); + + ok my $inf = new IO::Uncompress::Inflate \$buffer ; + my $uncomp ; + #ok $inf->read($uncomp) ; + my $actual = 0 ; + my $status = 1 ; + while (($status = $inf->read($uncomp)) > 0) { + $actual += $status ; + } + + is $actual, length($string) ; + is $uncomp, $string; + ok ! $inf->error() ; + ok $inf->eof() ; + ok my $hdr = $inf->getHeaderInfo(); + ok $inf->close ; + + return $hdr ; +} + +sub ReadHeaderInfoZlib +{ + my $string = shift || '' ; + my %opts = @_ ; + + my $buffer ; + ok my $def = new Compress::Zlib::Deflate AppendOutput => 1, %opts ; + cmp_ok $def->deflate($string, $buffer), '==', Z_OK; + cmp_ok $def->flush($buffer), '==', Z_OK; + #print "ReadHeaderInfoZlib\n"; hexDump(\$buffer); + + ok my $inf = new IO::Uncompress::Inflate \$buffer ; + my $uncomp ; + #ok $inf->read($uncomp) ; + my $actual = 0 ; + my $status = 1 ; + while (($status = $inf->read($uncomp)) > 0) { + $actual += $status ; + } + + is $actual, length($string) ; + is $uncomp, $string; + ok ! $inf->error() ; + ok $inf->eof() ; + ok my $hdr = $inf->getHeaderInfo(); + ok $inf->close ; + + return $hdr ; +} + +sub printHeaderInfo +{ + my $buffer = shift ; + my $inf = new IO::Uncompress::Inflate \$buffer ; + my $hdr = $inf->getHeaderInfo(); + + no warnings 'uninitialized' ; + while (my ($k, $v) = each %$hdr) { + print " $k -> $v\n" ; + } +} + + +# Check the Deflate Header Parameters +#======================================== + +my $name = "test.gz" ; +my $lex = new LexFile $name ; + +{ + title "Check default header settings" ; + + my $string = <<EOM; +some text +EOM + + my $hdr = ReadHeaderInfo($string); + + is $hdr->{CM}, 8, " CM is 8"; + is $hdr->{FDICT}, 0, " FDICT is 0"; + +} + +{ + title "Check user-defined header settings match zlib" ; + + my $string = <<EOM; +some text +EOM + + my @tests = ( + [ {-Level => 0}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Level => 1}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Level => 2}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], + [ {-Level => 3}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], + [ {-Level => 4}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], + [ {-Level => 5}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], + [ {-Level => 6}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], + [ {-Level => 7}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], + [ {-Level => 8}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], + [ {-Level => 9}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], + + [ {-Level => Z_NO_COMPRESSION }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Level => Z_BEST_SPEED }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Level => Z_BEST_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], + [ {-Level => Z_DEFAULT_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], + + [ {-Strategy => Z_HUFFMAN_ONLY}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + [ {-Strategy => Z_HUFFMAN_ONLY, + -Level => 3 }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], + ); + + foreach my $test (@tests) + { + my $opts = $test->[0] ; + my $expect = $test->[1] ; + + my @title ; + while (my ($k, $v) = each %$opts) + { + push @title, "$k => $v"; + } + title " Set @title"; + + my $hdr = ReadHeaderInfo($string, %$opts); + + my $hdr1 = ReadHeaderInfoZlib($string, %$opts); + + is $hdr->{CM}, 8, " CM is 8"; + is $hdr->{CINFO}, 7, " CINFO is 7"; + is $hdr->{FDICT}, 0, " FDICT is 0"; + + while (my ($k, $v) = each %$expect) + { + if (ZLIB_VERNUM >= 0x1220) + { is $hdr->{$k}, $v, " $k is $v" } + else + { ok 1, " Skip test for $k" } + } + + is $hdr->{CM}, $hdr1->{CM}, " CM matches"; + is $hdr->{CINFO}, $hdr1->{CINFO}, " CINFO matches"; + is $hdr->{FDICT}, $hdr1->{FDICT}, " FDICT matches"; + is $hdr->{FLEVEL}, $hdr1->{FLEVEL}, " FLEVEL matches"; + is $hdr->{FCHECK}, $hdr1->{FCHECK}, " FCHECK matches"; + } + + +} + +{ + title "No compressed data at all"; + + my $hdr = ReadHeaderInfo(""); + + is $hdr->{CM}, 8, " CM is 8"; + is $hdr->{FDICT}, 0, " FDICT is 0"; + + ok defined $hdr->{ADLER32}, " ADLER32 is defined" ; + is $hdr->{ADLER32}, 1, " ADLER32 is 1"; +} + +{ + # Header Corruption Tests + + my $string = <<EOM; +some text +EOM + + my $good ; + ok my $x = new IO::Compress::Deflate \$good ; + ok $x->write($string) ; + ok $x->close ; + + { + title "Header Corruption - FCHECK failure - 1st byte wrong"; + my $buffer = $good ; + substr($buffer, 0, 1) = "\x00" ; + + ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', + "CRC mismatch"; + } + + { + title "Header Corruption - FCHECK failure - 2nd byte wrong"; + my $buffer = $good ; + substr($buffer, 1, 1) = "\x00" ; + + ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', + "CRC mismatch"; + } + + + sub mkZlibHdr + { + my $method = shift ; + my $cinfo = shift ; + my $fdict = shift ; + my $level = shift ; + + my $cmf = ($method & 0x0F) ; + $cmf |= (($cinfo & 0x0F) << 4) ; + my $flg = (($level & 0x03) << 6) ; + $flg |= (($fdict & 0x01) << 5) ; + my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ; + $flg |= $fcheck ; + #print "check $fcheck\n"; + + return pack("CC", $cmf, $flg) ; + } + + { + title "Header Corruption - CM not 8"; + my $buffer = $good ; + my $header = mkZlibHdr(3, 6, 0, 3); + + substr($buffer, 0, 2) = $header; + + my $un = new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/', + " Not Deflate"; + } + +} + +{ + # Trailer Corruption tests + + my $string = <<EOM; +some text +EOM + + my $good ; + ok my $x = new IO::Compress::Deflate \$good ; + ok $x->write($string) ; + ok $x->close ; + + foreach my $trim (-4 .. -1) + { + my $got = $trim + 4 ; + foreach my $s (0, 1) + { + title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ; + my $buffer = $good ; + my $expected_trailing = substr($good, -4, 4) ; + substr($expected_trailing, $trim) = ''; + + substr($buffer, $trim) = ''; + writeFile($name, $buffer) ; + + ok my $gunz = new IO::Uncompress::Inflate $name, Strict => $s; + my $uncomp ; + if ($s) + { + ok $gunz->read($uncomp) < 0 ; + like $IO::Uncompress::Inflate::InflateError,"/Trailer Error: trailer truncated. Expected 4 bytes, got $got/", + "Trailer Error"; + } + else + { + is $gunz->read($uncomp), length $string ; + } + ok $gunz->eof() ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + } + + { + title "Trailer Corruption - CRC Wrong, strict" ; + my $buffer = $good ; + my $crc = unpack("N", substr($buffer, -4, 4)); + substr($buffer, -4, 4) = pack('N', $crc+1); + writeFile($name, $buffer) ; + + ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 1; + my $uncomp ; + ok $gunz->read($uncomp) < 0 ; + like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/', + "Trailer Error: CRC mismatch"; + ok $gunz->eof() ; + ok ! ${ $gunz->trailingData() } ; + ok $uncomp eq $string; + ok $gunz->close ; + } + + { + title "Trailer Corruption - CRC Wrong, no strict" ; + my $buffer = $good ; + my $crc = unpack("N", substr($buffer, -4, 4)); + substr($buffer, -4, 4) = pack('N', $crc+1); + writeFile($name, $buffer) ; + + ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 0; + my $uncomp ; + ok $gunz->read($uncomp) >= 0 ; + ok $gunz->eof() ; + ok ! ${ $gunz->trailingData() } ; + ok $uncomp eq $string; + ok $gunz->close ; + } +} + diff --git a/ext/Compress/Zlib/t/11truncate.t b/ext/Compress/Zlib/t/11truncate.t new file mode 100644 index 0000000000..a4e7fbefc9 --- /dev/null +++ b/ext/Compress/Zlib/t/11truncate.t @@ -0,0 +1,302 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 2374 + $extra; + + use_ok('Compress::Zlib', 2) ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; + + use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; + use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; + +} + + +my $hello = <<EOM ; +hello world +this is a test +some more stuff on this line +ad finally... +EOM + +my $blocksize = 10 ; + + +foreach my $CompressClass ('IO::Compress::Gzip', 'IO::Compress::Deflate') +{ + my $UncompressClass = getInverse($CompressClass); + + + my $compressed ; + my $cc ; + my $gz ; + if ($CompressClass eq 'IO::Compress::Gzip') { + ok( my $x = new IO::Compress::Gzip \$compressed, + -Name => "My name", + -Comment => "a comment", + -ExtraField => ['ab' => "extra"], + -HeaderCRC => 1); + ok $x->write($hello) ; + ok $x->close ; + $cc = $compressed ; + + ok($gz = new IO::Uncompress::Gunzip \$cc, + -Transparent => 0) + or diag "$GunzipError"; + my $un; + ok $gz->read($un) > 0 ; + ok $gz->close(); + ok $un eq $hello ; + } + else { + ok( my $x = new $CompressClass(\$compressed)); + ok $x->write($hello) ; + ok $x->close ; + $cc = $compressed ; + + ok($gz = new $UncompressClass(\$cc, + -Transparent => 0)) + or diag "$GunzipError"; + my $un; + ok $gz->read($un) > 0 ; + ok $gz->close(); + ok $un eq $hello ; + } + + + for my $trans ( 0 .. 1) + { + title "Testing $CompressClass, Transparent $trans"; + + my $info = $gz->getHeaderInfo() ; + my $header_size = $info->{HeaderLength}; + my $trailer_size = $info->{TrailerLength}; + ok 1, "Compressed size is " . length($compressed) ; + ok 1, "Header size is $header_size" ; + ok 1, "Trailer size is $trailer_size" ; + + title "Fingerprint Truncation"; + foreach my $i (1) + { + my $name = "test.gz" ; + unlink $name ; + my $lex = new LexFile $name ; + + ok 1, "Length $i" ; + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + + my $gz = new $UncompressClass $name, + -BlockSize => $blocksize, + -Transparent => $trans; + if ($trans) { + ok $gz; + ok ! $gz->error() ; + my $buff ; + ok $gz->read($buff) == length($part) ; + ok $buff eq $part ; + ok $gz->eof() ; + $gz->close(); + } + else { + ok !$gz; + } + + } + + title "Header Truncation"; + # + # Any header corruption past the fingerprint is considered catastrophic + # so even if Transparent is set, it should still fail + # + foreach my $i (2 .. $header_size -1) + { + my $name = "test.gz" ; + unlink $name ; + my $lex = new LexFile $name ; + + ok 1, "Length $i" ; + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + ok ! defined new $UncompressClass $name, + -BlockSize => $blocksize, + -Transparent => $trans; + #ok $gz->eof() ; + } + + title "Compressed Data Truncation"; + foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size) + { + + my $name = "test.gz" ; + unlink $name ; + my $lex = new LexFile $name ; + + ok 1, "Length $i" ; + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + ok my $gz = new $UncompressClass $name, + -BlockSize => $blocksize, + -Transparent => $trans; + my $un ; + my $status = 0 ; + $status = $gz->read($un) while $status >= 0 ; + ok $status < 0 ; + ok $gz->eof() ; + ok $gz->error() ; + $gz->close(); + } + + # RawDeflate does not have a trailer + next if $CompressClass eq 'IO::Compress::RawDeflate' ; + + title "Compressed Trailer Truncation"; + foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 ) + { + foreach my $lax (0, 1) + { + my $name = "test.gz" ; + unlink $name ; + my $lex = new LexFile $name ; + + ok 1, "Length $i, Lax $lax" ; + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + ok my $gz = new $UncompressClass $name, + -BlockSize => $blocksize, + -Strict => !$lax, + -Append => 1, + -Transparent => $trans; + my $un = ''; + my $status = 1 ; + $status = $gz->read($un) while $status > 0 ; + + if ($lax) + { + is $un, $hello; + is $status, 0 + or diag "Status $status Error is " . $gz->error() ; + ok $gz->eof() + or diag "Status $status Error is " . $gz->error() ; + ok ! $gz->error() ; + } + else + { + ok $status < 0 + or diag "Status $status Error is " . $gz->error() ; + ok $gz->eof() + or diag "Status $status Error is " . $gz->error() ; + ok $gz->error() ; + } + + $gz->close(); + } + } + } +} + + +foreach my $CompressClass ( 'IO::Compress::RawDeflate') +{ + my $UncompressClass = getInverse($CompressClass); + my $Error = getErrorRef($UncompressClass); + + my $compressed ; + ok( my $x = new IO::Compress::RawDeflate \$compressed); + ok $x->write($hello) ; + ok $x->close ; + + + my $cc = $compressed ; + + my $gz ; + ok($gz = new $UncompressClass(\$cc, + -Transparent => 0)) + or diag "$$Error\n"; + my $un; + ok $gz->read($un) > 0 ; + ok $gz->close(); + ok $un eq $hello ; + + for my $trans (0 .. 1) + { + title "Testing $CompressClass, Transparent = $trans"; + + my $info = $gz->getHeaderInfo() ; + my $header_size = $info->{HeaderLength}; + my $trailer_size = $info->{TrailerLength}; + ok 1, "Compressed size is " . length($compressed) ; + ok 1, "Header size is $header_size" ; + ok 1, "Trailer size is $trailer_size" ; + + + title "Compressed Data Truncation"; + foreach my $i (0 .. $blocksize) + { + + my $name = "test.gz" ; + unlink $name ; + my $lex = new LexFile $name ; + + ok 1, "Length $i" ; + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + my $gz = new $UncompressClass $name, + -BlockSize => $blocksize, + -Transparent => $trans; + if ($trans) { + ok $gz; + ok ! $gz->error() ; + my $buff = ''; + ok $gz->read($buff) == length $part ; + ok $buff eq $part ; + ok $gz->eof() ; + $gz->close(); + } + else { + ok !$gz; + } + } + + foreach my $i ($blocksize+1 .. length($compressed)-1) + { + + my $name = "test.gz" ; + unlink $name ; + my $lex = new LexFile $name ; + + ok 1, "Length $i" ; + my $part = substr($compressed, 0, $i); + writeFile($name, $part); + ok my $gz = new $UncompressClass $name, + -BlockSize => $blocksize, + -Transparent => $trans; + my $un ; + my $status = 0 ; + $status = $gz->read($un) while $status >= 0 ; + ok $status < 0 ; + ok $gz->eof() ; + ok $gz->error() ; + $gz->close(); + } + } + +} + diff --git a/ext/Compress/Zlib/t/12any.t b/ext/Compress/Zlib/t/12any.t new file mode 100644 index 0000000000..7939358ad4 --- /dev/null +++ b/ext/Compress/Zlib/t/12any.t @@ -0,0 +1,87 @@ + +use lib 't'; + +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 63 + $extra ; + + use_ok('Compress::Zlib', 2) ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; + + use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; + use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; + use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ; +} + +foreach my $Class ( map { "IO::Compress::$_" } qw( Gzip Deflate RawDeflate) ) +{ + + for my $trans ( 0, 1 ) + { + title "AnyInflate(Transparent => $trans) with $Class" ; + my $string = <<EOM; +some text +EOM + + my $buffer ; + my $x = new $Class(\$buffer) ; + ok $x, " create $Class object" ; + ok $x->write($string), " write to object" ; + ok $x->close, " close ok" ; + + my $unc = new IO::Uncompress::AnyInflate \$buffer, Transparent => $trans ; + + ok $unc, " Created AnyInflate object" ; + my $uncomp ; + ok $unc->read($uncomp) > 0 + or print "# $IO::Uncompress::AnyInflate::AnyInflateError\n"; + ok $unc->eof(), " at eof" ; + #ok $unc->type eq $Type; + + is $uncomp, $string, " expected output" ; + } + +} + +{ + title "AnyInflate with Non-compressed data" ; + + my $string = <<EOM; +This is not compressed data +EOM + + my $buffer = $string ; + + my $unc ; + my $keep = $buffer ; + $unc = new IO::Uncompress::AnyInflate \$buffer, -Transparent => 0 ; + ok ! $unc," no AnyInflate object when -Transparent => 0" ; + is $buffer, $keep ; + + $buffer = $keep ; + $unc = new IO::Uncompress::AnyInflate \$buffer, -Transparent => 1 ; + ok $unc, " AnyInflate object when -Transparent => 1" ; + + my $uncomp ; + ok $unc->read($uncomp) > 0 ; + ok $unc->eof() ; + #ok $unc->type eq $Type; + + is $uncomp, $string ; +} diff --git a/ext/Compress/Zlib/t/13prime.t b/ext/Compress/Zlib/t/13prime.t new file mode 100644 index 0000000000..bc8a09eacf --- /dev/null +++ b/ext/Compress/Zlib/t/13prime.t @@ -0,0 +1,134 @@ +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 10612 + $extra ; + + + use_ok('Compress::Zlib', 2) ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; + + use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; + use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; +} + + +my $hello = <<EOM ; +hello world +this is a test +some more stuff on this line +ad finally... +EOM + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + my $UncompressClass = getInverse($CompressClass); + + + print "#\n# Testing $UncompressClass\n#\n"; + + my $compressed ; + my $cc ; + my $gz ; + my $hsize ; + if ($CompressClass eq 'IO::Compress::Gzip') { + ok( my $x = new IO::Compress::Gzip \$compressed, + -Name => "My name", + -Comment => "this is a comment", + -ExtraField => [ 'ab' => "extra"], + -HeaderCRC => 1); + ok $x->write($hello) ; + ok $x->close ; + $cc = $compressed ; + + #hexDump($compressed) ; + + ok($gz = new IO::Uncompress::Gunzip \$cc, + #-Strict => 1, + -Transparent => 0) + or print "$GunzipError\n"; + my $un; + ok $gz->read($un) > 0 ; + ok $gz->close(); + ok $un eq $hello ; + } + else { + ok( my $x = new $CompressClass(\$compressed)); + ok $x->write($hello) ; + ok $x->close ; + $cc = $compressed ; + + ok($gz = new $UncompressClass(\$cc, + -Transparent => 0)) + or print "$GunzipError\n"; + my $un; + ok $gz->read($un) > 0 ; + ok $gz->close(); + ok $un eq $hello ; + } + + for my $blocksize (1,2,13) + { + for my $i (0 .. length($compressed) - 1) + { + for my $useBuf (0 .. 1) + { + print "#\n# BlockSize $blocksize, Length $i, Buffer $useBuf\n#\n" ; + my $name = "test.gz" ; + unlink $name ; + my $lex = new LexFile $name ; + + my $prime = substr($compressed, 0, $i); + my $rest = substr($compressed, $i); + + my $start ; + if ($useBuf) { + $start = \$rest ; + } + else { + $start = $name ; + writeFile($name, $rest); + } + + #my $gz = new $UncompressClass $name, + my $gz = new $UncompressClass $start, + -Append => 1, + -BlockSize => $blocksize, + -Prime => $prime, + -Transparent => 0 + ; + ok $gz; + ok ! $gz->error() ; + my $un ; + my $status = 1 ; + $status = $gz->read($un) while $status > 0 ; + ok $status == 0 + or print "status $status\n" ; + ok ! $gz->error() + or print "Error is '" . $gz->error() . "'\n"; + ok $un eq $hello + or print "# got [$un]\n"; + ok $gz->eof() ; + ok $gz->close() ; + } + } + } +} diff --git a/ext/Compress/Zlib/t/14gzopen.t b/ext/Compress/Zlib/t/14gzopen.t new file mode 100644 index 0000000000..b15c353f4b --- /dev/null +++ b/ext/Compress/Zlib/t/14gzopen.t @@ -0,0 +1,588 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; +use IO::File ; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 208 + $extra ; + + use_ok('Compress::Zlib', 2) ; + use_ok('Compress::Gzip::Constants') ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; +} + + +my $hello = <<EOM ; +hello world +this is a test +EOM + +my $len = length $hello ; + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + +# gzip tests +#=========== + +my $name = "test.gz" ; +my ($x, $uncomp) ; + +ok my $fil = gzopen($name, "wb") ; + +is $gzerrno, 0, 'gzerrno is 0'; +is $fil->gzerror(), 0, "gzerror() returned 0"; + +is $fil->gztell(), 0, "gztell returned 0"; +is $gzerrno, 0, 'gzerrno is 0'; + +is $fil->gzwrite($hello), $len ; +is $gzerrno, 0, 'gzerrno is 0'; + +is $fil->gztell(), $len, "gztell returned $len"; +is $gzerrno, 0, 'gzerrno is 0'; + +ok ! $fil->gzclose ; + +ok $fil = gzopen($name, "rb") ; + +ok ! $fil->gzeof() ; +is $gzerrno, 0, 'gzerrno is 0'; +is $fil->gztell(), 0; + +is $fil->gzread($uncomp), $len; + +is $fil->gztell(), $len; +ok $fil->gzeof() ; +ok ! $fil->gzclose ; +ok $fil->gzeof() ; + +unlink $name ; + +ok $hello eq $uncomp ; + +# check that a number can be gzipped +my $number = 7603 ; +my $num_len = 4 ; + +ok $fil = gzopen($name, "wb") ; + +is $gzerrno, 0; + +is $fil->gzwrite($number), $num_len, "gzwrite returned $num_len" ; +is $gzerrno, 0, 'gzerrno is 0'; +ok $fil->gzflush(Z_FINISH) ; + +is $gzerrno, 0, 'gzerrno is 0'; + +ok ! $fil->gzclose ; + +cmp_ok $gzerrno, '==', 0; + +ok $fil = gzopen($name, "rb") ; + +ok (($x = $fil->gzread($uncomp)) == $num_len) ; + +ok $fil->gzerror() == 0 || $fil->gzerror() == Z_STREAM_END; +ok $gzerrno == 0 || $gzerrno == Z_STREAM_END; +ok $fil->gzeof() ; + +ok ! $fil->gzclose ; +ok $fil->gzeof() ; + +ok $gzerrno == 0 + or print "# gzerrno is $gzerrno\n" ; + +unlink $name ; + +ok $number == $uncomp ; +ok $number eq $uncomp ; + + +# now a bigger gzip test + +my $text = 'text' ; +my $file = "$text.gz" ; + +ok my $f = gzopen($file, "wb") ; + +# generate a long random string +my $contents = '' ; +foreach (1 .. 5000) + { $contents .= chr int rand 256 } + +$len = length $contents ; + +ok $f->gzwrite($contents) == $len ; + +ok ! $f->gzclose ; + +ok $f = gzopen($file, "rb") ; + +ok ! $f->gzeof() ; + +my $uncompressed ; +is $f->gzread($uncompressed, $len), $len ; + +ok $contents eq $uncompressed + + or print "# Length orig $len" . + ", Length uncompressed " . length($uncompressed) . "\n" ; + +ok $f->gzeof() ; +ok ! $f->gzclose ; + +unlink($file) ; + +# gzip - readline tests +# ====================== + +# first create a small gzipped text file +$name = "test.gz" ; +my @text = (<<EOM, <<EOM, <<EOM, <<EOM) ; +this is line 1 +EOM +the second line +EOM +the line after the previous line +EOM +the final line +EOM + +$text = join("", @text) ; + +ok $fil = gzopen($name, "wb") ; +ok $fil->gzwrite($text) == length $text ; +ok ! $fil->gzclose ; + +# now try to read it back in +ok $fil = gzopen($name, "rb") ; +ok ! $fil->gzeof() ; +my $line = ''; +for my $i (0 .. @text -2) +{ + ok $fil->gzreadline($line) > 0; + ok $line eq $text[$i] ; + ok ! $fil->gzeof() ; +} + +# now read the last line +ok $fil->gzreadline($line) > 0; +ok $line eq $text[-1] ; +ok $fil->gzeof() ; + +# read past the eof +is $fil->gzreadline($line), 0; + +ok $fil->gzeof() ; +ok ! $fil->gzclose ; +ok $fil->gzeof() ; +unlink($name) ; + +# a text file with a very long line (bigger than the internal buffer) +my $line1 = ("abcdefghijklmnopq" x 2000) . "\n" ; +my $line2 = "second line\n" ; +$text = $line1 . $line2 ; +ok $fil = gzopen($name, "wb") ; +ok $fil->gzwrite($text) == length $text ; +ok ! $fil->gzclose ; + +# now try to read it back in +ok $fil = gzopen($name, "rb") ; +ok ! $fil->gzeof() ; +my $i = 0 ; +my @got = (); +while ($fil->gzreadline($line) > 0) { + $got[$i] = $line ; + ++ $i ; +} +ok $i == 2 ; +ok $got[0] eq $line1 ; +ok $got[1] eq $line2 ; + +ok $fil->gzeof() ; +ok ! $fil->gzclose ; +ok $fil->gzeof() ; + +unlink $name ; + +# a text file which is not termined by an EOL + +$line1 = "hello hello, I'm back again\n" ; +$line2 = "there is no end in sight" ; + +$text = $line1 . $line2 ; +ok $fil = gzopen($name, "wb") ; +ok $fil->gzwrite($text) == length $text ; +ok ! $fil->gzclose ; + +# now try to read it back in +ok $fil = gzopen($name, "rb") ; +@got = () ; $i = 0 ; +while ($fil->gzreadline($line) > 0) { + $got[$i] = $line ; + ++ $i ; +} +ok $i == 2 ; +ok $got[0] eq $line1 ; +ok $got[1] eq $line2 ; + +ok $fil->gzeof() ; +ok ! $fil->gzclose ; + +unlink $name ; + +{ + + title 'mix gzread and gzreadline'; + + # case 1: read a line, then a block. The block is + # smaller than the internal block used by + # gzreadline + my $name = "test.gz" ; + my $lex = new LexFile $name ; + $line1 = "hello hello, I'm back again\n" ; + $line2 = "abc" x 200 ; + my $line3 = "def" x 200 ; + + $text = $line1 . $line2 . $line3 ; + ok $fil = gzopen($name, "wb"), ' gzopen for write ok' ; + is $fil->gzwrite($text), length $text, ' gzwrite ok' ; + is $fil->gztell(), length $text, ' gztell ok' ; + ok ! $fil->gzclose, ' gzclose ok' ; + + # now try to read it back in + ok $fil = gzopen($name, "rb"), ' gzopen for read ok' ; + ok ! $fil->gzeof(), ' !gzeof' ; + cmp_ok $fil->gzreadline($line), '>', 0, ' gzreadline' ; + is $fil->gztell(), length $line1, ' gztell ok' ; + ok ! $fil->gzeof(), ' !gzeof' ; + is $line, $line1, ' got expected line' ; + cmp_ok $fil->gzread($line, length $line2), '>', 0, ' gzread ok' ; + is $fil->gztell(), length($line1)+length($line2), ' gztell ok' ; + ok ! $fil->gzeof(), ' !gzeof' ; + is $line, $line2, ' read expected block' ; + cmp_ok $fil->gzread($line, length $line3), '>', 0, ' gzread ok' ; + is $fil->gztell(), length($text), ' gztell ok' ; + ok $fil->gzeof(), ' !gzeof' ; + is $line, $line3, ' read expected block' ; + ok ! $fil->gzclose, ' gzclose' ; +} + +{ + title "Pass gzopen a filehandle - use IO::File" ; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $hello = "hello" ; + my $len = length $hello ; + + unlink $name ; + + my $f = new IO::File ">$name" ; + ok $f; + + ok my $fil = gzopen($f, "wb") ; + + ok $fil->gzwrite($hello) == $len ; + + ok ! $fil->gzclose ; + + $f = new IO::File "<$name" ; + ok $fil = gzopen($name, "rb") ; + + my $uncmomp; + ok (($x = $fil->gzread($uncomp)) == $len) + or print "# length $x, expected $len\n" ; + + ok $fil->gzeof() ; + ok ! $fil->gzclose ; + ok $fil->gzeof() ; + + unlink $name ; + + ok $hello eq $uncomp ; + + +} + + +{ + title "Pass gzopen a filehandle - use open" ; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $hello = "hello" ; + my $len = length $hello ; + + unlink $name ; + + open F, ">$name" ; + + ok my $fil = gzopen(*F, "wb") ; + + is $fil->gzwrite($hello), $len ; + + ok ! $fil->gzclose ; + + open F, "<$name" ; + ok $fil = gzopen(*F, "rb") ; + + my $uncmomp; + $x = $fil->gzread($uncomp); + is $x, $len ; + + ok $fil->gzeof() ; + ok ! $fil->gzclose ; + ok $fil->gzeof() ; + + unlink $name ; + + ok $hello eq $uncomp ; + + +} + +foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) +{ + my $stdin = $stdio->[0]; + my $stdout = $stdio->[1]; + + title "Pass gzopen a filehandle - use $stdin" ; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $hello = "hello" ; + my $len = length $hello ; + + unlink $name ; + + ok open(SAVEOUT, ">&STDOUT"), " save STDOUT"; + my $dummy = fileno SAVEOUT; + ok open(STDOUT, ">$name"), " redirect STDOUT" ; + + my $status = 0 ; + + my $fil = gzopen($stdout, "wb") ; + + $status = $fil && + ($fil->gzwrite($hello) == $len) && + ($fil->gzclose == 0) ; + + open(STDOUT, ">&SAVEOUT"); + + ok $status, " wrote to stdout"; + + open(SAVEIN, "<&STDIN"); + ok open(STDIN, "<$name"), " redirect STDIN"; + $dummy = fileno SAVEIN; + + ok $fil = gzopen($stdin, "rb") ; + + my $uncmomp; + ok (($x = $fil->gzread($uncomp)) == $len) + or print "# length $x, expected $len\n" ; + + ok $fil->gzeof() ; + ok ! $fil->gzclose ; + ok $fil->gzeof() ; + + open(STDIN, "<&SAVEIN"); + + unlink $name ; + + ok $hello eq $uncomp ; + + +} + +{ + title 'test parameters for gzopen'; + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $fil; + + unlink $name ; + + # missing parameters + eval ' $fil = gzopen() ' ; + like $@, mkEvalErr('Not enough arguments for Compress::Zlib::gzopen'), + ' gzopen with missing mode fails' ; + + # unknown parameters + $fil = gzopen($name, "xy") ; + ok ! defined $fil, ' gzopen with unknown mode fails' ; + + $fil = gzopen($name, "ab") ; + ok $fil, ' gzopen with mode "ab" is ok' ; + + $fil = gzopen($name, "wb6") ; + ok $fil, ' gzopen with mode "wb6" is ok' ; + + $fil = gzopen($name, "wbf") ; + ok $fil, ' gzopen with mode "wbf" is ok' ; + + $fil = gzopen($name, "wbh") ; + ok $fil, ' gzopen with mode "wbh" is ok' ; +} + +{ + title 'Read operations when opened for writing'; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + ok $fil = gzopen($name, "wb"), ' gzopen for writing' ; + ok !$fil->gzeof(), ' !eof'; ; + is $fil->gzread(), Z_STREAM_ERROR, " gzread returns Z_STREAM_ERROR" ; +} + +{ + title 'write operations when opened for reading'; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + my $test = "hello" ; + ok $fil = gzopen($name, "wb"), " gzopen for writing" ; + is $fil->gzwrite($text), length $text, " gzwrite ok" ; + ok ! $fil->gzclose, " gzclose ok" ; + + ok $fil = gzopen($name, "rb"), " gzopen for reading" ; + is $fil->gzwrite(), Z_STREAM_ERROR, " gzwrite returns Z_STREAM_ERROR" ; +} + +{ + title 'read/write a non-readable/writable file'; + + SKIP: + { + my $name ; + my $lex = new LexFile $name ; + writeFile($name, "abc"); + chmod 0444, $name ; + + skip "Cannot create non-writable file", 3 + if -w $name ; + + ok ! -w $name, " input file not writable"; + + my $fil = gzopen($name, "wb") ; + ok !$fil, " gzopen returns undef" ; + ok $gzerrno, " gzerrno ok" or + diag " gzerrno $gzerrno\n"; + + chmod 0777, $name ; + } + + SKIP: + { + my $name ; + my $lex = new LexFile $name ; + writeFile($name, "abc"); + chmod 0222, $name ; + + skip "Cannot create non-readable file", 3 + if -r $name ; + + ok ! -r $name, " input file not readable"; + $gzerrno = 0; + $fil = gzopen($name, "rb") ; + ok !$fil, " gzopen returns undef" ; + ok $gzerrno, " gzerrno ok"; + chmod 0777, $name ; + } + +} + +{ + title "gzseek" ; + + my $buff ; + my $name ;#= "test.gz" ; + my $lex = new LexFile $name ; + + my $first = "beginning" ; + my $last = "the end" ; + my $iow = gzopen($name, "w"); + $iow->gzwrite($first) ; + ok $iow->gzseek(5, SEEK_CUR) ; + is $iow->gztell(), length($first)+5; + ok $iow->gzseek(0, SEEK_CUR) ; + is $iow->gztell(), length($first)+5; + ok $iow->gzseek(length($first)+10, SEEK_SET) ; + is $iow->gztell(), length($first)+10; + + $iow->gzwrite($last) ; + $iow->gzclose ; + + ok GZreadFile($name) eq $first . "\x00" x 10 . $last ; + + my $io = gzopen($name, "r"); + ok $io->gzseek(length($first), SEEK_CUR) ; + ok ! $io->gzeof; + is $io->gztell(), length($first); + + ok $io->gzread($buff, 5) ; + is $buff, "\x00" x 5 ; + is $io->gztell(), length($first) + 5; + + is $io->gzread($buff, 0), 0 ; + #is $buff, "\x00" x 5 ; + is $io->gztell(), length($first) + 5; + + ok $io->gzseek(0, SEEK_CUR) ; + my $here = $io->gztell() ; + is $here, length($first)+5; + + ok $io->gzseek($here+5, SEEK_SET) ; + is $io->gztell(), $here+5 ; + ok $io->gzread($buff, 100) ; + ok $buff eq $last ; + ok $io->gzeof; +} + +{ + # seek error cases + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $a = gzopen($name, "w"); + + ok ! $a->gzerror() + or print "# gzerrno is $Compress::Zlib::gzerrno \n" ; + eval { $a->gzseek(-1, 10) ; }; + like $@, mkErr("gzseek: unknown value, 10, for whence parameter"); + + eval { $a->gzseek(-1, SEEK_END) ; }; + like $@, mkErr("gzseek: cannot seek backwards"); + + $a->gzwrite("fred"); + $a->gzclose ; + + + my $u = gzopen($name, "r"); + + eval { $u->gzseek(-1, 10) ; }; + like $@, mkErr("gzseek: unknown value, 10, for whence parameter"); + + eval { $u->gzseek(-1, SEEK_END) ; }; + like $@, mkErr("gzseek: SEEK_END not allowed"); + + eval { $u->gzseek(-1, SEEK_CUR) ; }; + like $@, mkErr("gzseek: cannot seek backwards"); +} diff --git a/ext/Compress/Zlib/t/15multi.t b/ext/Compress/Zlib/t/15multi.t new file mode 100644 index 0000000000..fbbc64e36a --- /dev/null +++ b/ext/Compress/Zlib/t/15multi.t @@ -0,0 +1,144 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 575 + $extra ; + + use_ok('Compress::Zlib', 2) ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ; + use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; + use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; +} + + +my @buffers ; +push @buffers, <<EOM ; +hello world +this is a test +some more stuff on this line +ad finally... +EOM + +push @buffers, <<EOM ; +some more stuff +EOM + +push @buffers, <<EOM ; +even more stuff +EOM + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + my $UncompressClass = getInverse($CompressClass); + + + my $cc ; + my $gz ; + my $hsize ; + my %headers = () ; + + + foreach my $fb ( qw( file filehandle buffer ) ) + { + + foreach my $i (1 .. @buffers) { + + title "Testing $CompressClass with $i streams to $fb"; + + my @buffs = @buffers[0..$i -1] ; + + if ($CompressClass eq 'IO::Compress::Gzip') { + %headers = ( + Strict => 0, + Comment => "this is a comment", + ExtraField => "some extra", + HeaderCRC => 1); + + } + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + my $output ; + if ($fb eq 'buffer') + { + my $compressed = ''; + $output = \$compressed; + } + elsif ($fb eq 'filehandle') + { + $output = new IO::File ">$name" ; + } + else + { + $output = $name ; + } + + my $x = new $CompressClass($output, AutoClose => 1, %headers); + isa_ok $x, $CompressClass, ' $x' ; + + foreach my $buffer (@buffs) { + ok $x->write($buffer), " Write OK" ; + # this will add an extra "empty" stream + ok $x->newStream(), " newStream OK" ; + } + ok $x->close, " Close ok" ; + + #hexDump($compressed) ; + + foreach my $unc ($UncompressClass, 'IO::Uncompress::AnyInflate') { + title " Testing $CompressClass with $unc and $i streams, from $fb"; + $cc = $output ; + if ($fb eq 'filehandle') + { + $cc = new IO::File "<$name" ; + } + my $gz = new $unc($cc, + Strict => 0, + AutoClose => 1, + Append => 1, + MultiStream => 1, + Transparent => 0); + isa_ok $gz, $unc, ' $gz' ; + + my $un = ''; + 1 while $gz->read($un) > 0 ; + #print "[[$un]]\n" while $gz->read($un) > 0 ; + ok ! $gz->error(), " ! error()" + or diag "Error is " . $gz->error() ; + ok $gz->eof(), " eof()"; + ok $gz->close(), " close() ok" + or diag "errno $!\n" ; + + is $gz->streamCount(), $i +1, " streamCount ok" + or diag "Stream count is " . $gz->streamCount(); + ok $un eq join('', @buffs), " expected output" ; + + } + } + } +} + + +# corrupt one of the streams - all previous should be ok +# trailing stuff +# need a way to skip to the start of the next stream. +# check that "tell" works ok diff --git a/ext/Compress/Zlib/t/16oneshot.t b/ext/Compress/Zlib/t/16oneshot.t new file mode 100644 index 0000000000..b08960a7ec --- /dev/null +++ b/ext/Compress/Zlib/t/16oneshot.t @@ -0,0 +1,1515 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" ) + if $] < 5.005 ; + + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 2526 + $extra ; + + use_ok('Compress::Zlib', 2) ; + + use_ok('IO::Compress::Gzip', qw(gzip $GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw(gunzip $GunzipError)) ; + + use_ok('IO::Compress::Deflate', qw(deflate $DeflateError)) ; + use_ok('IO::Uncompress::Inflate', qw(inflate $InflateError)) ; + + use_ok('IO::Compress::RawDeflate', qw(rawdeflate $RawDeflateError)) ; + use_ok('IO::Uncompress::RawInflate', qw(rawinflate $RawInflateError)) ; + + use_ok('IO::Uncompress::AnyInflate', qw(anyinflate $AnyInflateError)) ; + +} + + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + + + +foreach my $bit ('IO::Compress::Gzip', + 'IO::Uncompress::Gunzip', + 'IO::Compress::Deflate', + 'IO::Uncompress::Inflate', + 'IO::Compress::RawDeflate', + 'IO::Uncompress::RawInflate', + 'IO::Uncompress::AnyInflate', + ) +{ + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + title "Testing $TopType Error Cases"; + + my $a; + my $x ; + + eval { $a = $Func->(\$a => \$x, Fred => 1) ;} ; + like $@, mkErr("^$TopType: unknown key value\\(s\\) Fred"), ' Illegal Parameters'; + + eval { $a = $Func->() ;} ; + like $@, mkErr("^$TopType: expected at least 1 parameters"), ' No Parameters'; + + eval { $a = $Func->(\$x, \1) ;} ; + like $@, mkErr("^$TopType: output buffer is read-only"), ' Output is read-only' ; + + my $in ; + eval { $a = $Func->($in, \$x) ;} ; + like $@, mkErr("^$TopType: input filename is undef or null string"), + ' Input filename undef' ; + + $in = ''; + eval { $a = $Func->($in, \$x) ;} ; + like $@, mkErr("^$TopType: input filename is undef or null string"), + ' Input filename empty' ; + + $in = 'abc'; + my $lex1 = new LexFile($in) ; + writeFile($in, "abc"); + my $out = $in ; + eval { $a = $Func->($in, $out) ;} ; + like $@, mkErr("^$TopType: input and output filename are identical"), + ' Input and Output filename are the same'; + + eval { $a = $Func->(\$in, \$in) ;} ; + like $@, mkErr("^$TopType: input and output buffer are identical"), + ' Input and Output buffer are the same'; + + my $out_file = "abcde.out"; + my $lex = new LexFile($out_file) ; + open OUT, ">$out_file" ; + eval { $a = $Func->(\*OUT, \*OUT) ;} ; + like $@, mkErr("^$TopType: input and output handle are identical"), + ' Input and Output handle are the same'; + + close OUT; + is -s $out_file, 0, " File zero length" ; + { + my %x = () ; + my $object = bless \%x, "someClass" ; + + # Buffer not a scalar reference + #eval { $a = $Func->(\$x, \%x) ;} ; + eval { $a = $Func->(\$x, $object) ;} ; + like $@, mkErr("^$TopType: illegal output parameter"), + ' Bad Output Param'; + + + #eval { $a = $Func->(\%x, \$x) ;} ; + eval { $a = $Func->($object, \$x) ;} ; + like $@, mkErr("^$TopType: illegal input parameter"), + ' Bad Input Param'; + } + + my $filename = 'abc.def'; + ok ! -e $filename, " input file '$filename' does not exist"; + $a = $Func->($filename, \$x) ; + is $a, undef, " $TopType returned undef"; + like $$Error, "/^input file '$filename' does not exist\$/", " input File '$filename' does not exist"; + + $filename = '/tmp/abd/abc.def'; + ok ! -e $filename, " output File '$filename' does not exist"; + $a = $Func->(\$x, $filename) ; + is $a, undef, " $TopType returned undef"; + like $$Error, ("/^(cannot open file '$filename'|input file '$filename' does not exist):/"), " output File '$filename' does not exist"; + + $a = $Func->(\$x, '<abc>') ; + is $a, undef, " $TopType returned undef"; + like $$Error, "/Need input fileglob for outout fileglob/", + ' Output fileglob with no input fileglob'; + + $a = $Func->('<abc)>', '<abc>') ; + is $a, undef, " $TopType returned undef"; + like $$Error, "/Unmatched \\) in input fileglob/", + " Unmatched ) in input fileglob"; +} + +foreach my $bit ('IO::Uncompress::Gunzip', + 'IO::Uncompress::Inflate', + 'IO::Uncompress::RawInflate', + 'IO::Uncompress::AnyInflate', + ) +{ + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $data = "mary had a little lamb" ; + my $keep = $data ; + + for my $trans ( 0, 1) + { + title "Non-compressed data with $TopType, Transparent => $trans "; + my $a; + my $x ; + my $out = '' ; + + $a = $Func->(\$data, \$out, Transparent => $trans) ; + + is $data, $keep, " Input buffer not changed" ; + + if ($trans) + { + ok $a, " $TopType returned true" ; + is $out, $data, " got expected output" ; + ok ! $$Error, " no error [$$Error]" ; + } + else + { + ok ! $a, " $TopType returned false" ; + #like $$Error, '/xxx/', " error" ; + ok $$Error, " error is '$$Error'" ; + } + } +} + +foreach my $bit ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + my $TopTypeInverse = getInverse($bit); + my $FuncInverse = getTopFuncRef($TopTypeInverse); + my $ErrorInverse = getErrorRef($TopTypeInverse); + + title "$TopTypeInverse - corrupt data"; + + my $data = "abcd" x 100 ; + my $out; + + ok $Func->(\$data, \$out), " $TopType ok"; + + # corrupt the compressed data + substr($out, -10, 10) = "x" x 10 ; + + my $result; + ok ! $FuncInverse->(\$out => \$result, Transparent => 0), " $TopTypeInverse ok"; + ok $$ErrorInverse, " Got error '$$ErrorInverse'" ; + + #is $result, $data, " data ok"; + + ok ! anyinflate(\$out => \$result, Transparent => 0), " anyinflate ok"; + ok $AnyInflateError, " Got error '$AnyInflateError'" ; +} + + +foreach my $bit ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + my $TopTypeInverse = getInverse($bit); + my $FuncInverse = getTopFuncRef($TopTypeInverse); + + for my $append ( 1, 0 ) + { + my $already = ''; + $already = 'abcde' if $append ; + + for my $buffer ( undef, '', "abcde" ) + { + + my $disp_content = defined $buffer ? $buffer : '<undef>' ; + + my $keep = $buffer; + my $out_file = "abcde.out"; + my $in_file = "abcde.in"; + + { + title "$TopType - From Buff to Buff content '$disp_content' Append $append" ; + + my $output = $already; + ok &$Func(\$buffer, \$output, Append => $append), ' Compressed ok' ; + + is $keep, $buffer, " Input buffer not changed" ; + my $got = anyUncompress(\$output, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + + } + + { + title "$TopType - From Buff to Array Ref content '$disp_content' Append $append" ; + + my @output = ('first') ; + ok &$Func(\$buffer, \@output, Append => $append), ' Compressed ok' ; + + is $output[0], 'first', " Array[0] unchanged"; + is $keep, $buffer, " Input buffer not changed" ; + my $got = anyUncompress($output[1]); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + } + + { + title "$TopType - From Array Ref to Array Ref content '$disp_content' Append $append" ; + + my @output = ('first') ; + my @input = ( \$buffer); + ok &$Func(\@input, \@output, Append => $append), ' Compressed ok' ; + + is $output[0], 'first', " Array[0] unchanged"; + is $keep, $buffer, " Input buffer not changed" ; + my $got = anyUncompress($output[1]); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + + } + + { + title "$TopType - From Buff to Filename content '$disp_content' Append $append" ; + + my $lex = new LexFile($out_file) ; + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + + ok &$Func(\$buffer, $out_file, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + } + + { + title "$TopType - From Buff to Handle content '$disp_content' Append $append" ; + + my $lex = new LexFile($out_file) ; + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + my $of = new IO::File ">>$out_file" ; + ok $of, " Created output filehandle" ; + + ok &$Func(\$buffer, $of, AutoClose => 1, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + } + + + { + title "$TopType - From Filename to Filename content '$disp_content' Append $append" ; + + my $lex = new LexFile($in_file, $out_file) ; + writeFile($in_file, $buffer); + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + + ok &$Func($in_file => $out_file, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + + } + + { + title "$TopType - From Filename to Handle content '$disp_content' Append $append" ; + + my $lex = new LexFile($in_file, $out_file) ; + writeFile($in_file, $buffer); + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + my $out = new IO::File ">>$out_file" ; + + ok &$Func($in_file, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + + } + + { + title "$TopType - From Filename to Buffer content '$disp_content' Append $append" ; + + my $lex = new LexFile($in_file, $out_file) ; + writeFile($in_file, $buffer); + + my $out = $already; + + ok &$Func($in_file => \$out, Append => $append), ' Compressed ok' ; + + my $got = anyUncompress(\$out, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $got, $buffer, " Uncompressed matches original"; + + } + + { + title "$TopType - From Handle to Filename content '$disp_content' Append $append" ; + + my $lex = new LexFile($in_file, $out_file) ; + writeFile($in_file, $buffer); + my $in = new IO::File "<$in_file" ; + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + + ok &$Func($in, $out_file, Append => $append), ' Compressed ok' + or diag "error is $GzipError" ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $buffer, $got, " Uncompressed matches original"; + + } + + { + title "$TopType - From Handle to Handle content '$disp_content' Append $append" ; + + my $lex = new LexFile($in_file, $out_file) ; + writeFile($in_file, $buffer); + my $in = new IO::File "<$in_file" ; + + ok ! -e $out_file, " Output file does not exist"; + writeFile($out_file, $already); + my $out = new IO::File ">>$out_file" ; + + ok &$Func($in, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; + + ok -e $out_file, " Created output file"; + my $got = anyUncompress($out_file, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $buffer, $got, " Uncompressed matches original"; + + } + + { + title "$TopType - From Handle to Buffer content '$disp_content' Append $append" ; + + my $lex = new LexFile($in_file, $out_file) ; + writeFile($in_file, $buffer); + my $in = new IO::File "<$in_file" ; + + my $out = $already ; + + ok &$Func($in, \$out, Append => $append), ' Compressed ok' ; + + my $got = anyUncompress(\$out, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $buffer, $got, " Uncompressed matches original"; + + } + + { + title "$TopType - From stdin (via '-') to Buffer content '$disp_content' Append $append" ; + + my $lex = new LexFile($in_file, $out_file) ; + writeFile($in_file, $buffer); + + open(SAVEIN, "<&STDIN"); + my $dummy = fileno SAVEIN ; + ok open(STDIN, "<$in_file"), " redirect STDIN"; + + my $out = $already; + + ok &$Func('-', \$out, Append => $append), ' Compressed ok' + or diag $$Error ; + + open(STDIN, "<&SAVEIN"); + + my $got = anyUncompress(\$out, $already); + $got = undef if ! defined $buffer && $got eq '' ; + is $buffer, $got, " Uncompressed matches original"; + + } + + } + } +} + +foreach my $bit ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $TopTypeInverse = getInverse($bit); + my $FuncInverse = getTopFuncRef($TopTypeInverse); + + my ($file1, $file2) = ("file1", "file2"); + my $lex = new LexFile($file1, $file2) ; + + writeFile($file1, "data1"); + writeFile($file2, "data2"); + my $of = new IO::File "<$file1" ; + ok $of, " Created output filehandle" ; + + my @input = ( undef, "", $file2, \undef, \'', \"abcde", $of) ; + my @expected = ("", "", $file2, "", "", "abcde", "data1"); + my @uexpected = ("", "", "data2", "", "", "abcde", "data1"); + + my @keep = @input ; + + { + title "$TopType - From Array Ref to Array Ref" ; + + my @output = ('first') ; + ok &$Func(\@input, \@output, AutoClose => 0), ' Compressed ok' ; + + is $output[0], 'first', " Array[0] unchanged"; + + is_deeply \@input, \@keep, " Input array not changed" ; + my @got = shift @output; + foreach (@output) { push @got, anyUncompress($_) } + + is_deeply \@got, ['first', @expected], " Got Expected uncompressed data"; + + } + + { + title "$TopType - From Array Ref to Buffer" ; + + # rewind the filehandle + $of->open("<$file1") ; + + my $output ; + ok &$Func(\@input, \$output, AutoClose => 0), ' Compressed ok' ; + + my $got = anyUncompress(\$output); + + is $got, join('', @expected), " Got Expected uncompressed data"; + } + + { + title "$TopType - From Array Ref to Filename" ; + + my ($file3) = ("file3"); + my $lex = new LexFile($file3) ; + + # rewind the filehandle + $of->open("<$file1") ; + + my $output ; + ok &$Func(\@input, $file3, AutoClose => 0), ' Compressed ok' ; + + my $got = anyUncompress($file3); + + is $got, join('', @expected), " Got Expected uncompressed data"; + } + + { + title "$TopType - From Array Ref to Filehandle" ; + + my ($file3) = ("file3"); + my $lex = new LexFile($file3) ; + + my $fh3 = new IO::File ">$file3"; + + # rewind the filehandle + $of->open("<$file1") ; + + my $output ; + ok &$Func(\@input, $fh3, AutoClose => 0), ' Compressed ok' ; + + $fh3->close(); + + my $got = anyUncompress($file3); + + is $got, join('', @expected), " Got Expected uncompressed data"; + } +} + +foreach my $bit ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $TopTypeInverse = getInverse($bit); + my $FuncInverse = getTopFuncRef($TopTypeInverse); + + my @inFiles = map { "in$_.tmp" } 1..4; + my @outFiles = map { "out$_.tmp" } 1..4; + my $lex = new LexFile(@inFiles, @outFiles); + + writeFile($_, "data $_") foreach @inFiles ; + + { + title "$TopType - Hash Ref: to filename" ; + + my $output ; + ok &$Func( { $inFiles[0] => $outFiles[0], + $inFiles[1] => $outFiles[1], + $inFiles[2] => $outFiles[2] } ), ' Compressed ok' ; + + foreach (0 .. 2) + { + my $got = anyUncompress($outFiles[$_]); + is $got, "data $inFiles[$_]", " Uncompressed $_ matches original"; + } + } + + { + title "$TopType - Hash Ref: to buffer" ; + + my @buffer ; + ok &$Func( { $inFiles[0] => \$buffer[0], + $inFiles[1] => \$buffer[1], + $inFiles[2] => \$buffer[2] } ), ' Compressed ok' ; + + foreach (0 .. 2) + { + my $got = anyUncompress(\$buffer[$_]); + is $got, "data $inFiles[$_]", " Uncompressed $_ matches original"; + } + } + + { + title "$TopType - Hash Ref: to undef" ; + + my @buffer ; + my %hash = ( $inFiles[0] => undef, + $inFiles[1] => undef, + $inFiles[2] => undef, + ); + + ok &$Func( \%hash ), ' Compressed ok' ; + + foreach (keys %hash) + { + my $got = anyUncompress(\$hash{$_}); + is $got, "data $_", " Uncompressed $_ matches original"; + } + } + + { + title "$TopType - Filename to Hash Ref" ; + + my %output ; + ok &$Func( $inFiles[0] => \%output), ' Compressed ok' ; + + is keys %output, 1, " one pair in hash" ; + my ($k, $v) = each %output; + is $k, $inFiles[0], " key is '$inFiles[0]'"; + my $got = anyUncompress($v); + is $got, "data $inFiles[0]", " Uncompressed matches original"; + } + + { + title "$TopType - File Glob to Hash Ref" ; + + my %output ; + ok &$Func( '<in*.tmp>' => \%output), ' Compressed ok' ; + + is keys %output, 4, " four pairs in hash" ; + foreach my $fil (@inFiles) + { + ok exists $output{$fil}, " key '$fil' exists" ; + my $got = anyUncompress($output{$fil}); + is $got, "data $fil", " Uncompressed matches original"; + } + } + + +# if (0) +# { +# title "$TopType - Hash Ref to Array Ref" ; +# +# my @output = ('first') ; +# ok &$Func( { \@input, \@output } , AutoClose => 0), ' Compressed ok' ; +# +# is $output[0], 'first', " Array[0] unchanged"; +# +# is_deeply \@input, \@keep, " Input array not changed" ; +# my @got = shift @output; +# foreach (@output) { push @got, anyUncompress($_) } +# +# is_deeply \@got, ['first', @expected], " Got Expected uncompressed data"; +# +# } +# +# if (0) +# { +# title "$TopType - From Array Ref to Buffer" ; +# +# # rewind the filehandle +# $of->open("<$file1") ; +# +# my $output ; +# ok &$Func(\@input, \$output, AutoClose => 0), ' Compressed ok' ; +# +# my $got = anyUncompress(\$output); +# +# is $got, join('', @expected), " Got Expected uncompressed data"; +# } +# +# if (0) +# { +# title "$TopType - From Array Ref to Filename" ; +# +# my ($file3) = ("file3"); +# my $lex = new LexFile($file3) ; +# +# # rewind the filehandle +# $of->open("<$file1") ; +# +# my $output ; +# ok &$Func(\@input, $file3, AutoClose => 0), ' Compressed ok' ; +# +# my $got = anyUncompress($file3); +# +# is $got, join('', @expected), " Got Expected uncompressed data"; +# } +# +# if (0) +# { +# title "$TopType - From Array Ref to Filehandle" ; +# +# my ($file3) = ("file3"); +# my $lex = new LexFile($file3) ; +# +# my $fh3 = new IO::File ">$file3"; +# +# # rewind the filehandle +# $of->open("<$file1") ; +# +# my $output ; +# ok &$Func(\@input, $fh3, AutoClose => 0), ' Compressed ok' ; +# +# $fh3->close(); +# +# my $got = anyUncompress($file3); +# +# is $got, join('', @expected), " Got Expected uncompressed data"; +# } +} + +foreach my $bit ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + for my $files ( [qw(a1)], [qw(a1 a2 a3)] ) + { + + my $tmpDir1 = 'tmpdir1'; + my $tmpDir2 = 'tmpdir2'; + my $lex = new LexDir($tmpDir1, $tmpDir2) ; + + mkdir $tmpDir1, 0777; + mkdir $tmpDir2, 0777; + + ok -d $tmpDir1, " Temp Directory $tmpDir1 exists"; + #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist"; + + my @files = map { "$tmpDir1/$_.tmp" } @$files ; + foreach (@files) { writeFile($_, "abc $_") } + + my @expected = map { "abc $_" } @files ; + my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ; + + { + title "$TopType - From FileGlob to FileGlob files [@$files]" ; + + ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' Compressed ok' + or diag $$Error ; + + my @copy = @expected; + for my $file (@outFiles) + { + is anyUncompress($file), shift @copy, " got expected from $file" ; + } + + is @copy, 0, " got all files"; + } + + { + title "$TopType - From FileGlob to Array files [@$files]" ; + + my @buffer = ('first') ; + ok &$Func("<$tmpDir1/a*.tmp>" => \@buffer), ' Compressed ok' + or diag $$Error ; + + is shift @buffer, 'first'; + + my @copy = @expected; + for my $buffer (@buffer) + { + is anyUncompress($buffer), shift @copy, " got expected " ; + } + + is @copy, 0, " got all files"; + } + + { + title "$TopType - From FileGlob to Buffer files [@$files]" ; + + my $buffer ; + ok &$Func("<$tmpDir1/a*.tmp>" => \$buffer), ' Compressed ok' + or diag $$Error ; + + #hexDump(\$buffer); + + my $got = anyUncompress([ \$buffer, MultiStream => 1 ]); + + is $got, join("", @expected), " got expected" ; + } + + { + title "$TopType - From FileGlob to Filename files [@$files]" ; + + my $filename = "abcde"; + my $lex = new LexFile($filename) ; + + ok &$Func("<$tmpDir1/a*.tmp>" => $filename), ' Compressed ok' + or diag $$Error ; + + #hexDump(\$buffer); + + my $got = anyUncompress([$filename, MultiStream => 1]); + + is $got, join("", @expected), " got expected" ; + } + + { + title "$TopType - From FileGlob to Filehandle files [@$files]" ; + + my $filename = "abcde"; + my $lex = new LexFile($filename) ; + my $fh = new IO::File ">$filename"; + + ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1), ' Compressed ok' + or diag $$Error ; + + #hexDump(\$buffer); + + my $got = anyUncompress([$filename, MultiStream => 1]); + + is $got, join("", @expected), " got expected" ; + } + } + +} + +foreach my $bit ('IO::Uncompress::Gunzip', + 'IO::Uncompress::Inflate', + 'IO::Uncompress::RawInflate', + 'IO::Uncompress::AnyInflate', + ) +{ + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $buffer = "abcde" ; + my $buffer2 = "ABCDE" ; + my $keep_orig = $buffer; + + my $comp = compressBuffer($TopType, $buffer) ; + my $comp2 = compressBuffer($TopType, $buffer2) ; + my $keep_comp = $comp; + + my $incumbent = "incumbent data" ; + + for my $append (0, 1) + { + my $expected = $buffer ; + $expected = $incumbent . $buffer if $append ; + + { + title "$TopType - From Buff to Buff, Append($append)" ; + + my $output ; + $output = $incumbent if $append ; + ok &$Func(\$comp, \$output, Append => $append), ' Uncompressed ok' ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Buff to Array, Append($append)" ; + + my @output = ('first'); + #$output = $incumbent if $append ; + ok &$Func(\$comp, \@output, Append => $append), ' Uncompressed ok' ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output[0], 'first', " Uncompressed matches original"; + is ${ $output[1] }, $buffer, " Uncompressed matches original" + or diag $output[1] ; + is @output, 2, " only 2 elements in the array" ; + } + + { + title "$TopType - From Buff to Filename, Append($append)" ; + + my $out_file = "abcde"; + my $lex = new LexFile($out_file) ; + if ($append) + { writeFile($out_file, $incumbent) } + else + { ok ! -e $out_file, " Output file does not exist" } + + ok &$Func(\$comp, $out_file, Append => $append), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Buff to Handle, Append($append)" ; + + my $out_file = "abcde"; + my $lex = new LexFile($out_file) ; + my $of ; + if ($append) { + writeFile($out_file, $incumbent) ; + $of = new IO::File "+< $out_file" ; + } + else { + ok ! -e $out_file, " Output file does not exist" ; + $of = new IO::File "> $out_file" ; + } + isa_ok $of, 'IO::File', ' $of' ; + + ok &$Func(\$comp, $of, Append => $append, AutoClose => 1), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Filename to Filename, Append($append)" ; + + my $out_file = "abcde.out"; + my $in_file = "abcde.in"; + my $lex = new LexFile($in_file, $out_file) ; + if ($append) + { writeFile($out_file, $incumbent) } + else + { ok ! -e $out_file, " Output file does not exist" } + + writeFile($in_file, $comp); + + ok &$Func($in_file, $out_file, Append => $append), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Filename to Handle, Append($append)" ; + + my $out_file = "abcde.out"; + my $in_file = "abcde.in"; + my $lex = new LexFile($in_file, $out_file) ; + my $out ; + if ($append) { + writeFile($out_file, $incumbent) ; + $out = new IO::File "+< $out_file" ; + } + else { + ok ! -e $out_file, " Output file does not exist" ; + $out = new IO::File "> $out_file" ; + } + isa_ok $out, 'IO::File', ' $out' ; + + writeFile($in_file, $comp); + + ok &$Func($in_file, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Filename to Buffer, Append($append)" ; + + my $in_file = "abcde.in"; + my $lex = new LexFile($in_file) ; + writeFile($in_file, $comp); + + my $output ; + $output = $incumbent if $append ; + + ok &$Func($in_file, \$output, Append => $append), ' Uncompressed ok' ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Handle to Filename, Append($append)" ; + + my $out_file = "abcde.out"; + my $in_file = "abcde.in"; + my $lex = new LexFile($in_file, $out_file) ; + if ($append) + { writeFile($out_file, $incumbent) } + else + { ok ! -e $out_file, " Output file does not exist" } + + writeFile($in_file, $comp); + my $in = new IO::File "<$in_file" ; + + ok &$Func($in, $out_file, Append => $append), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Handle to Handle, Append($append)" ; + + my $out_file = "abcde.out"; + my $in_file = "abcde.in"; + my $lex = new LexFile($in_file, $out_file) ; + my $out ; + if ($append) { + writeFile($out_file, $incumbent) ; + $out = new IO::File "+< $out_file" ; + } + else { + ok ! -e $out_file, " Output file does not exist" ; + $out = new IO::File "> $out_file" ; + } + isa_ok $out, 'IO::File', ' $out' ; + + writeFile($in_file, $comp); + my $in = new IO::File "<$in_file" ; + + ok &$Func($in, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ; + + ok -e $out_file, " Created output file"; + my $content = readFile($out_file) ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $content, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From Filename to Buffer, Append($append)" ; + + my $in_file = "abcde.in"; + my $lex = new LexFile($in_file) ; + writeFile($in_file, $comp); + my $in = new IO::File "<$in_file" ; + + my $output ; + $output = $incumbent if $append ; + + ok &$Func($in, \$output, Append => $append), ' Uncompressed ok' ; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output, $expected, " Uncompressed matches original"; + } + + { + title "$TopType - From stdin (via '-') to Buffer content, Append($append) " ; + + my $in_file = "abcde.in"; + my $lex = new LexFile($in_file) ; + writeFile($in_file, $comp); + + ok open(SAVEIN, "<&STDIN"), " save STDIN"; + my $dummy = fileno SAVEIN ; + ok open(STDIN, "<$in_file"), " redirect STDIN"; + + my $output ; + $output = $incumbent if $append ; + + ok &$Func('-', \$output, Append => $append), ' Uncompressed ok' + or diag $$Error ; + + ok open(STDIN, "<&SAVEIN"), " put STDIN back"; + + is $keep_comp, $comp, " Input buffer not changed" ; + is $output, $expected, " Uncompressed matches original"; + } + } + + { + title "$TopType - From Handle to Buffer, InputLength" ; + + my $out_file = "abcde.out"; + my $in_file = "abcde.in"; + my $lex = new LexFile($in_file, $out_file) ; + my $out ; + + my $expected = $buffer ; + my $appended = 'appended'; + my $len_appended = length $appended; + writeFile($in_file, $comp . $appended . $comp . $appended) ; + my $in = new IO::File "<$in_file" ; + + ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ; + + is $out, $expected, " Uncompressed matches original"; + + my $buff; + is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok"; + is $buff, $appended, " Appended data ok"; + + $out = ''; + ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ; + + is $out, $expected, " Uncompressed matches original"; + + $buff = ''; + is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok"; + is $buff, $appended, " Appended data ok"; + } + + for my $stdin ('-', *STDIN) # , \*STDIN) + { + title "$TopType - From stdin (via $stdin) to Buffer content, InputLength" ; + + my $in_file = "abcde.in"; + my $lex = new LexFile($in_file) ; + my $expected = $buffer ; + my $appended = 'appended'; + my $len_appended = length $appended; + writeFile($in_file, $comp . $appended . $comp . $appended) ; + + ok open(SAVEIN, "<&STDIN"), " save STDIN"; + my $dummy = fileno SAVEIN ; + ok open(STDIN, "<$in_file"), " redirect STDIN"; + + my $output ; + + ok &$Func($stdin, \$output, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' + or diag $$Error ; + + my $buff ; + is read(STDIN, $buff, $len_appended), $len_appended, " Length of Appended data ok"; + + is $output, $expected, " Uncompressed matches original"; + is $buff, $appended, " Appended data ok"; + + $output = ''; + ok &$Func($stdin, \$output, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' + or diag $$Error ; + + $buff = ''; + is read(STDIN, $buff, $len_appended), $len_appended, " Length of Appended data ok" + or diag "read failed $!"; + + is $output, $expected, " Uncompressed matches original"; + is $buff, $appended, " Appended data ok"; + + ok open(STDIN, "<&SAVEIN"), " put STDIN back"; + } +} + +foreach my $bit ('IO::Uncompress::Gunzip', + 'IO::Uncompress::Inflate', + 'IO::Uncompress::RawInflate', + 'IO::Uncompress::AnyInflate', + ) +{ + # TODO -- Add Append mode tests + + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $buffer = "abcde" ; + my $keep_orig = $buffer; + + + my $null = compressBuffer($TopType, "") ; + my $undef = compressBuffer($TopType, undef) ; + my $comp = compressBuffer($TopType, $buffer) ; + my $keep_comp = $comp; + + my $incumbent = "incumbent data" ; + + my ($file1, $file2) = ("file1", "file2"); + my $lex = new LexFile($file1, $file2) ; + + writeFile($file1, compressBuffer($TopType,"data1")); + writeFile($file2, compressBuffer($TopType,"data2")); + + my $of = new IO::File "<$file1" ; + ok $of, " Created output filehandle" ; + + my @input = ($file2, \$undef, \$null, \$comp, $of) ; + my @expected = ('data2', '', '', 'abcde', 'data1'); + + my @keep = @input ; + + { + title "$TopType - From ArrayRef to Buffer" ; + + my $output ; + ok &$Func(\@input, \$output, AutoClose => 0), ' UnCompressed ok' ; + + is $output, join('', @expected) + } + + { + title "$TopType - From ArrayRef to Filename" ; + + my $output = 'abc'; + my $lex = new LexFile $output; + $of->open("<$file1") ; + + ok &$Func(\@input, $output, AutoClose => 0), ' UnCompressed ok' ; + + is readFile($output), join('', @expected) + } + + { + title "$TopType - From ArrayRef to Filehandle" ; + + my $output = 'abc'; + my $lex = new LexFile $output; + my $fh = new IO::File ">$output" ; + $of->open("<$file1") ; + + ok &$Func(\@input, $fh, AutoClose => 0), ' UnCompressed ok' ; + $fh->close; + + is readFile($output), join('', @expected) + } + + { + title "$TopType - From Array Ref to Array Ref" ; + + my @output = (\'first') ; + $of->open("<$file1") ; + ok &$Func(\@input, \@output, AutoClose => 0), ' UnCompressed ok' ; + + is_deeply \@input, \@keep, " Input array not changed" ; + is_deeply [map { defined $$_ ? $$_ : "" } @output], + ['first', @expected], + " Got Expected uncompressed data"; + + } +} + +foreach my $bit ('IO::Uncompress::Gunzip', + 'IO::Uncompress::Inflate', + 'IO::Uncompress::RawInflate', + 'IO::Uncompress::AnyInflate', + ) +{ + # TODO -- Add Append mode tests + + my $Error = getErrorRef($bit); + my $Func = getTopFuncRef($bit); + my $TopType = getTopFuncName($bit); + + my $tmpDir1 = 'tmpdir1'; + my $tmpDir2 = 'tmpdir2'; + my $lex = new LexDir($tmpDir1, $tmpDir2) ; + + mkdir $tmpDir1, 0777; + mkdir $tmpDir2, 0777; + + ok -d $tmpDir1, " Temp Directory $tmpDir1 exists"; + #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist"; + + my @files = map { "$tmpDir1/$_.tmp" } qw( a1 a2 a3) ; + foreach (@files) { writeFile($_, compressBuffer($TopType, "abc $_")) } + + my @expected = map { "abc $_" } @files ; + my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ; + + { + title "$TopType - From FileGlob to FileGlob" ; + + ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' UnCompressed ok' + or diag $$Error ; + + my @copy = @expected; + for my $file (@outFiles) + { + is readFile($file), shift @copy, " got expected from $file" ; + } + + is @copy, 0, " got all files"; + } + + { + title "$TopType - From FileGlob to Arrayref" ; + + my @output = (\'first'); + ok &$Func("<$tmpDir1/a*.tmp>" => \@output), ' UnCompressed ok' + or diag $$Error ; + + my @copy = ('first', @expected); + for my $data (@output) + { + is $$data, shift @copy, " got expected data" ; + } + + is @copy, 0, " got all files"; + } + + { + title "$TopType - From FileGlob to Buffer" ; + + my $output ; + ok &$Func("<$tmpDir1/a*.tmp>" => \$output), ' UnCompressed ok' + or diag $$Error ; + + is $output, join('', @expected), " got expected uncompressed data"; + } + + { + title "$TopType - From FileGlob to Filename" ; + + my $output = 'abc' ; + my $lex = new LexFile $output ; + ok ! -e $output, " $output does not exist" ; + ok &$Func("<$tmpDir1/a*.tmp>" => $output), ' UnCompressed ok' + or diag $$Error ; + + ok -e $output, " $output does exist" ; + is readFile($output), join('', @expected), " got expected uncompressed data"; + } + + { + title "$TopType - From FileGlob to Filehandle" ; + + my $output = 'abc' ; + my $lex = new LexFile $output ; + my $fh = new IO::File ">$output" ; + ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1), ' UnCompressed ok' + or diag $$Error ; + + ok -e $output, " $output does exist" ; + is readFile($output), join('', @expected), " got expected uncompressed data"; + } + +} + +foreach my $TopType ('IO::Compress::Gzip::gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + # TODO -- add the inflate classes + ) +{ + my $Error = getErrorRef($TopType); + my $Func = getTopFuncRef($TopType); + my $Name = getTopFuncName($TopType); + + title "More write tests" ; + + my $file1 = "file1" ; + my $file2 = "file2" ; + my $file3 = "file3" ; + my $lex = new LexFile $file1, $file2, $file3 ; + + writeFile($file1, "F1"); + writeFile($file2, "F2"); + writeFile($file3, "F3"); + + my @data = ( + [ '[]', "" ], + [ '[\""]', "" ], + [ '[\undef]', "" ], + [ '[\"abcd"]', "abcd" ], + [ '[\"ab", \"cd"]', "abcd" ], + + [ '$fh2', "F2" ], + [ '[\"a", $fh1, \"bc"]', "aF1bc"], + ) ; + + + foreach my $data (@data) + { + my ($send, $get) = @$data ; + + my $fh1 = new IO::File "< $file1" ; + my $fh2 = new IO::File "< $file2" ; + my $fh3 = new IO::File "< $file3" ; + + title "$send"; + my $copy; + eval "\$copy = $send"; + my $Answer ; + ok &$Func($copy, \$Answer), " $Name ok"; + + my $got = anyUncompress(\$Answer); + is $got, $get, " got expected output" ; + cmp_ok $$Error, '==', 0, " no error"; + + + } + + title "Array Input Error tests" ; + + @data = ( + '[[]]', + '[[[]]]', + '[[\"ab"], [\"cd"]]', + ) ; + + + foreach my $send (@data) + { + my $fh1 = new IO::File "< $file1" ; + my $fh2 = new IO::File "< $file2" ; + my $fh3 = new IO::File "< $file3" ; + + title "$send"; + my $copy; + eval "\$copy = $send"; + my $Answer ; + ok ! &$Func($copy, \$Answer), " $Name fails"; + + is $$Error, "unknown input parameter", " got error message"; + + } +} + +sub gzipGetHeader +{ + my $in = shift; + my $content = shift ; + my %opts = @_ ; + + my $out ; + my $got ; + + ok IO::Compress::Gzip::gzip($in, \$out, %opts), " gzip ok" ; + ok IO::Uncompress::Gunzip::gunzip(\$out, \$got), " gunzip ok" + or diag $GunzipError ; + is $got, $content, " got expected content" ; + + my $gunz = new IO::Uncompress::Gunzip \$out, Strict => 0 + or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; + ok $gunz, " Created IO::Uncompress::Gunzip object"; + my $hdr = $gunz->getHeaderInfo(); + ok $hdr, " got Header info"; + my $uncomp ; + ok $gunz->read($uncomp), " read ok" ; + is $uncomp, $content, " got expected content"; + ok $gunz->close, " closed ok" ; + + return $hdr ; + +} + +{ + title "Check gzip header default NAME & MTIME settings" ; + + my $file1 = "file1" ; + my $lex = new LexFile $file1; + + my $content = "hello "; + my $hdr ; + my $mtime ; + + writeFile($file1, $content); + $mtime = (stat($file1))[8]; + # make sure that the gzip file isn't created in the same + # second as the input file + sleep 3 ; + $hdr = gzipGetHeader($file1, $content); + + is $hdr->{Name}, $file1, " Name is '$file1'"; + is $hdr->{Time}, $mtime, " Time is ok"; + + title "Override Name" ; + + writeFile($file1, $content); + $mtime = (stat($file1))[8]; + sleep 3 ; + $hdr = gzipGetHeader($file1, $content, Name => "abcde"); + + is $hdr->{Name}, "abcde", " Name is 'abcde'" ; + is $hdr->{Time}, $mtime, " Time is ok"; + + title "Override Time" ; + + writeFile($file1, $content); + $hdr = gzipGetHeader($file1, $content, Time => 1234); + + is $hdr->{Name}, $file1, " Name is '$file1'" ; + is $hdr->{Time}, 1234, " Time is 1234"; + + title "Override Name and Time" ; + + writeFile($file1, $content); + $hdr = gzipGetHeader($file1, $content, Time => 4321, Name => "abcde"); + + is $hdr->{Name}, "abcde", " Name is 'abcde'" ; + is $hdr->{Time}, 4321, " Time is 4321"; + + title "Filehandle doesn't have default Name or Time" ; + my $fh = new IO::File "< $file1" + or diag "Cannot open '$file1': $!\n" ; + sleep 3 ; + my $before = time ; + $hdr = gzipGetHeader($fh, $content); + my $after = time ; + + ok ! defined $hdr->{Name}, " Name is undef"; + cmp_ok $hdr->{Time}, '>=', $before, " Time is ok"; + cmp_ok $hdr->{Time}, '<=', $after, " Time is ok"; + + $fh->close; + + title "Buffer doesn't have default Name or Time" ; + my $buffer = $content; + $before = time ; + $hdr = gzipGetHeader(\$buffer, $content); + $after = time ; + + ok ! defined $hdr->{Name}, " Name is undef"; + cmp_ok $hdr->{Time}, '>=', $before, " Time is ok"; + cmp_ok $hdr->{Time}, '<=', $after, " Time is ok"; +} + +# TODO add more error cases + diff --git a/ext/Compress/Zlib/t/17isize.t b/ext/Compress/Zlib/t/17isize.t new file mode 100644 index 0000000000..4241fe7341 --- /dev/null +++ b/ext/Compress/Zlib/t/17isize.t @@ -0,0 +1,152 @@ + +use lib 't'; +use strict ; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN +{ + plan skip_all => "Lengthy Tests Disabled\n" . + "set COMPRESS_ZLIB_RUN_ALL to run this test suite" + unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 76 + $extra ; + + + use_ok('Compress::Zlib', 2) ; + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + use_ok('Compress::Gzip::Constants'); +} + +my $compressed ; +my $expected_crc ; + +for my $wrap (0 .. 2) +{ + for my $offset ( -1 .. 1 ) + { + next if $wrap == 0 && $offset < 0 ; + + title "Wrap $wrap, Offset $offset" ; + + my $size = (GZIP_ISIZE_MAX * $wrap) + $offset ; + + my $expected_isize ; + if ($wrap == 0) { + $expected_isize = $offset ; + } + elsif ($wrap == 1 && $offset <= 0) { + $expected_isize = GZIP_ISIZE_MAX + $offset ; + } + elsif ($wrap > 1) { + $expected_isize = GZIP_ISIZE_MAX + $offset - 1; + } + else { + $expected_isize = $offset - 1; + } + + sub gzipClosure + { + my $gzip = shift ; + my $max = shift ; + + my $index = 0 ; + my $inc = 1024 * 5000 ; + my $buff = 'x' x $inc ; + my $left = $max ; + + return + sub { + + if ($max == 0 && $index == 0) { + $expected_crc = crc32('') ; + ok $gzip->close(), ' IO::Compress::Gzip::close ok X' ; + ++ $index ; + $_[0] .= $compressed; + return length $compressed ; + } + + return 0 if $index >= $max ; + + while ( ! length $compressed ) + { + $index += $inc ; + + if ($index <= $max) { + $gzip->write($buff) ; + #print "Write " . length($buff) . "\n" ; + #print "# LEN Compressed " . length($compressed) . "\n" ; + $expected_crc = crc32($buff, $expected_crc) ; + $left -= $inc ; + } + else { + #print "Write $left\n" ; + $gzip->write('x' x $left) ; + #print "# LEN Compressed " . length($compressed) . "\n" ; + $expected_crc = crc32('x' x $left, $expected_crc) ; + ok $gzip->close(), ' IO::Compress::Gzip::close ok ' ; + last ; + } + } + + my $len = length $compressed ; + $_[0] .= $compressed ; + $compressed = ''; + #print "# LEN $len\n" if $len <=0 ; + + return $len ; + }; + } + + my $gzip = new IO::Compress::Gzip \$compressed, + -Append => 0, + -HeaderCRC => 1; + + ok $gzip, " Created IO::Compress::Gzip object"; + + my $gunzip = new IO::Uncompress::Gunzip gzipClosure($gzip, $size), + -BlockSize => 1024 * 500 , + -Append => 0, + -Strict => 1; + + ok $gunzip, " Created IO::Uncompress::Gunzip object"; + + my $inflate = *$gunzip->{Inflate} ; + my $deflate = *$gzip->{Deflate} ; + + my $status ; + my $uncompressed; + my $actual = 0 ; + while (($status = $gunzip->read($uncompressed)) > 0) { + #print "# READ $status\n" ; + $actual += $status ; + } + + is $status, 0, ' IO::Uncompress::Gunzip::read returned 0' + or diag "error status is $status, error is $GunzipError" ; + + ok $gunzip->close(), " IO::Uncompress::Gunzip Closed ok" ; + + is $actual, $size, " Length of Gunzipped data is $size" + or diag "Expected $size, got $actual"; + + my $gunzip_hdr = $gunzip->getHeaderInfo(); + + is $gunzip_hdr->{ISIZE}, $expected_isize, + sprintf(" ISIZE is $expected_isize [0x%X]", $expected_isize); + is $gunzip_hdr->{CRC32}, $expected_crc, + sprintf(" CRC32 is $expected_crc [0x%X]", $expected_crc); + + $expected_crc = 0 ; + } +} + diff --git a/ext/Compress/Zlib/t/18lvalue.t b/ext/Compress/Zlib/t/18lvalue.t new file mode 100644 index 0000000000..5f9e43db54 --- /dev/null +++ b/ext/Compress/Zlib/t/18lvalue.t @@ -0,0 +1,68 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN +{ + plan(skip_all => "lvalue sub tests need Perl ??") + if $] < 5.006 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 10 + $extra ; + + use_ok('Compress::Zlib', 2) ; +} + + + +my $hello = <<EOM ; +hello world +this is a test +EOM + +my $len = length $hello ; + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + + +{ + title 'deflate/inflate with lvalue sub'; + + my $hello = "I am a HAL 9000 computer" ; + my $data = $hello ; + + my($X, $Z); + sub getData : lvalue { $data } + sub getX : lvalue { $X } + sub getZ : lvalue { $Z } + + ok my $x = new Compress::Zlib::Deflate ( -AppendOutput => 1 ); + + cmp_ok $x->deflate(getData, getX), '==', Z_OK ; + + cmp_ok $x->flush(getX), '==', Z_OK ; + + my $append = "Appended" ; + $X .= $append ; + + ok my $k = new Compress::Zlib::Inflate ( -AppendOutput => 1 ) ; + + cmp_ok $k->inflate(getX, getZ), '==', Z_STREAM_END ; ; + + ok $hello eq $Z ; + is $X, $append; + +} + + diff --git a/ext/Compress/Zlib/t/19destroy.t b/ext/Compress/Zlib/t/19destroy.t new file mode 100644 index 0000000000..a2671f749a --- /dev/null +++ b/ext/Compress/Zlib/t/19destroy.t @@ -0,0 +1,82 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN +{ + plan(skip_all => "Destroy not supported in Perl $]") + if $] == 5.008 || ( $] >= 5.005 && $] < 5.006) ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 23 + $extra ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ; + use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; + use_ok('IO::File') ; +} + + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate') +{ + title "Testing $CompressClass"; + + + { + # Check that the class destructor will call close + + my $name = "test.gz" ; + unlink $name ; + my $lex = new LexFile $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + + { + ok my $x = new $CompressClass $name, -AutoClose => 1 ; + + ok $x->write($hello) ; + } + + is anyUncompress($name), $hello ; + } + + { + # Tied filehandle destructor + + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + my $fh = new IO::File "> $name" ; + + { + ok my $x = new $CompressClass $fh, -AutoClose => 1 ; + + $x->write($hello) ; + } + + ok anyUncompress($name) eq $hello ; + } +} + diff --git a/ext/Compress/Zlib/t/20tied.t b/ext/Compress/Zlib/t/20tied.t new file mode 100644 index 0000000000..7d708d123d --- /dev/null +++ b/ext/Compress/Zlib/t/20tied.t @@ -0,0 +1,514 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +our ($BadPerl); + +BEGIN +{ + plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" ) + if $] < 5.005 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + my $tests ; + $BadPerl = ($] >= 5.006 or $] <= 5.008) ; + + if ($BadPerl) { + $tests = 731 ; + } + else { + $tests = 771 ; + } + + plan tests => $tests + $extra ; + + use_ok('Compress::Zlib', 2) ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; + + use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; + use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; +} + + +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + + + + +our ($UncompressClass); + + +sub myGZreadFile +{ + my $filename = shift ; + my $init = shift ; + + + my $fil = new $UncompressClass $filename, + -Strict => 1, + -Append => 1 + ; + + my $data ; + $data = $init if defined $init ; + 1 while $fil->read($data) > 0; + + $fil->close ; + return $data ; +} + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + + + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate') +{ + next if $BadPerl ; + + + title "Testing $CompressClass"; + + + my $x ; + my $gz = new $CompressClass(\$x); + + my $buff ; + + eval { getc($gz) } ; + like $@, mkErr("^getc Not Available: File opened only for output"); + + eval { read($gz, $buff, 1) } ; + like $@, mkErr("^read Not Available: File opened only for output"); + + eval { <$gz> } ; + like $@, mkErr("^readline Not Available: File opened only for output"); + +} + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate') +{ + next if $BadPerl; + $UncompressClass = getInverse($CompressClass); + + title "Testing $UncompressClass"; + + my $gc ; + my $guz = new $CompressClass(\$gc); + $guz->write("abc") ; + $guz->close(); + + my $x ; + my $gz = new $UncompressClass(\$gc); + + my $buff ; + + eval { print $gz "abc" } ; + like $@, mkErr("^print Not Available: File opened only for intput"); + + eval { printf $gz "fmt", "abc" } ; + like $@, mkErr("^printf Not Available: File opened only for intput"); + + #eval { write($gz, $buff, 1) } ; + #like $@, mkErr("^write Not Available: File opened only for intput"); + +} + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate') +{ + $UncompressClass = getInverse($CompressClass); + + title "Testing $CompressClass and $UncompressClass"; + + + { + # Write + # these tests come almost 100% from IO::String + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $io = $CompressClass->new($name); + + is $io->tell(), 0 ; + + my $heisan = "Heisan\n"; + print $io $heisan ; + + ok ! $io->eof; + + is $io->tell(), length($heisan) ; + + print($io "a", "b", "c"); + + { + local($\) = "\n"; + print $io "d", "e"; + local($,) = ","; + print $io "f", "g", "h"; + } + + my $foo = "1234567890"; + + ok syswrite($io, $foo, length($foo)) == length($foo) ; + if ( $[ < 5.6 ) + { is $io->syswrite($foo, length $foo), length $foo } + else + { is $io->syswrite($foo), length $foo } + ok $io->syswrite($foo, length($foo)) == length $foo; + ok $io->write($foo, length($foo), 5) == 5; + ok $io->write("xxx\n", 100, -1) == 1; + + for (1..3) { + printf $io "i(%d)", $_; + $io->printf("[%d]\n", $_); + } + select $io; + print "\n"; + select STDOUT; + + close $io ; + + ok $io->eof; + + is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . + ("1234567890" x 3) . "67890\n" . + "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; + + + } + + { + # Read + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $iow = new $CompressClass $name ; + print $iow $str ; + close $iow; + + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name ; + + ok ! $io->eof; + is $io->tell(), 0 ; + my @lines = <$io>; + is @lines, 6 + or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; + is $lines[1], "of a paragraph\n" ; + is join('', @lines), $str ; + is $., 6; + is $io->tell(), length($str) ; + + ok $io->eof; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined(<$io>) || + defined($io->getc) || + read($io, $buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok !$io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = <$io>; + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = <$io>; + ok $io->eof; + ok @lines == 2 + or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# $lines[0]\n"; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (<$io>) { + push(@lines, $_); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 + or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + + if (! $BadPerl) { + eval { read($io, $buf, -1) } ; + like $@, mkErr("length parameter is negative"); + } + + is read($io, $buf, 0), 0, "Requested 0 bytes" ; + + ok read($io, $buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok sysread($io, $buf, 3, 2) == 3 ; + ok $buf eq "Ths i" + or print "# [$buf]\n" ;; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + } + + { + # Read from non-compressed file + + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + writeFile($name, $str); + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name, -Transparent => 1 ; + + ok defined $io; + ok ! $io->eof; + ok $io->tell() == 0 ; + my @lines = <$io>; + ok @lines == 6; + ok $lines[1] eq "of a paragraph\n" ; + ok join('', @lines) eq $str ; + ok $. == 6; + ok $io->tell() == length($str) ; + + ok $io->eof; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined(<$io>) || + defined($io->getc) || + read($io, $buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = <$io>; + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = <$io>; + ok $io->eof; + ok @lines == 2 + or print "# exected 2 lines, got " . scalar(@lines) . "\n"; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# [$lines[0]]\n" ; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (<$io>) { + push(@lines, $_); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + ok read($io, $buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok sysread($io, $buf, 3, 2) == 3 ; + ok $buf eq "Ths i"; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + + } + + { + # Vary the length parameter in a read + + my $str = <<EOT; +x +x +This is an example +of a paragraph + + +and a single line. + +EOT + $str = $str x 100 ; + + + foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) + { + foreach my $trans (0, 1) + { + foreach my $append (0, 1) + { + title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; + + my $name = "testz.gz" ; + my $lex = new LexFile $name ; + + if ($trans) { + writeFile($name, $str) ; + } + else { + my $iow = new $CompressClass $name ; + print $iow $str ; + close $iow; + } + + + my $io = $UncompressClass->new($name, + -Append => $append, + -Transparent => $trans); + + my $buf; + + is $io->tell(), 0; + + if ($append) { + 1 while $io->read($buf, $bufsize) > 0; + } + else { + my $tmp ; + $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; + } + is length $buf, length $str; + ok $buf eq $str ; + ok ! $io->error() ; + ok $io->eof; + } + } + } + } + +} diff --git a/ext/Compress/Zlib/t/21newtied.t b/ext/Compress/Zlib/t/21newtied.t new file mode 100644 index 0000000000..923878661e --- /dev/null +++ b/ext/Compress/Zlib/t/21newtied.t @@ -0,0 +1,394 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +our ($BadPerl); + +BEGIN +{ + plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" ) + if $] < 5.006 ; + + my $tests ; + + $BadPerl = ($] >= 5.006 or $] <= 5.008) ; + + if ($BadPerl) { + $tests = 242 ; + } + else { + $tests = 242 ; + } + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => $tests + $extra ; + + use_ok('Compress::Zlib', 2) ; + + use_ok('IO::Compress::Gzip', qw($GzipError)) ; + use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; + + use_ok('IO::Compress::Deflate', qw($DeflateError)) ; + use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; + + use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; + use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; + + +} + + +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + + +our ($UncompressClass); + + +sub myGZreadFile +{ + my $filename = shift ; + my $init = shift ; + + + my $fil = new $UncompressClass $filename, + -Strict => 1, + -Append => 1 + ; + + my $data ; + $data = $init if defined $init ; + 1 while $fil->read($data) > 0; + + $fil->close ; + return $data ; +} + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + + + +foreach my $CompressClass ('IO::Compress::Gzip', + 'IO::Compress::Deflate', + 'IO::Compress::RawDeflate', + ) +{ + $UncompressClass = getInverse($CompressClass); + + title "Testing $CompressClass and $UncompressClass"; + + + + { + # Write + # these tests come almost 100% from IO::String + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $io = $CompressClass->new($name); + + is tell($io), 0 ; + is $io->tell(), 0 ; + + my $heisan = "Heisan\n"; + print $io $heisan ; + + ok ! eof($io); + ok ! $io->eof(); + + is tell($io), length($heisan) ; + is $io->tell(), length($heisan) ; + + $io->print("a", "b", "c"); + + { + local($\) = "\n"; + print $io "d", "e"; + local($,) = ","; + print $io "f", "g", "h"; + } + + my $foo = "1234567890"; + + ok syswrite($io, $foo, length($foo)) == length($foo) ; + if ( $[ < 5.6 ) + { is $io->syswrite($foo, length $foo), length $foo } + else + { is $io->syswrite($foo), length $foo } + ok $io->syswrite($foo, length($foo)) == length $foo; + ok $io->write($foo, length($foo), 5) == 5; + ok $io->write("xxx\n", 100, -1) == 1; + + for (1..3) { + printf $io "i(%d)", $_; + $io->printf("[%d]\n", $_); + } + select $io; + print "\n"; + select STDOUT; + + close $io ; + + ok eof($io); + ok $io->eof(); + + is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . + ("1234567890" x 3) . "67890\n" . + "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; + + + } + + { + # Read + my $str = <<EOT; +This is an example +of a paragraph + + +and a single line. + +EOT + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $iow = new $CompressClass $name ; + print $iow $str ; + close $iow; + + my @tmp; + my $buf; + { + my $io = new $UncompressClass $name ; + + ok ! $io->eof; + ok ! eof $io; + is $io->tell(), 0 ; + is tell($io), 0 ; + my @lines = <$io>; + is @lines, 6 + or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; + is $lines[1], "of a paragraph\n" ; + is join('', @lines), $str ; + is $., 6; + #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ; + is $io->tell(), length($str) ; + is tell($io), length($str) ; + + ok $io->eof; + ok eof $io; + + ok ! ( defined($io->getline) || + (@tmp = $io->getlines) || + defined(<$io>) || + defined($io->getc) || + read($io, $buf, 100) != 0) ; + } + + + { + local $/; # slurp mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = $io->getlines; + ok $io->eof; + ok @lines == 1 && $lines[0] eq $str; + + $io = $UncompressClass->new($name); + ok ! $io->eof; + my $line = <$io>; + ok $line eq $str; + ok $io->eof; + } + + { + local $/ = ""; # paragraph mode + my $io = $UncompressClass->new($name); + ok ! $io->eof; + my @lines = <$io>; + ok $io->eof; + ok @lines == 2 + or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; + ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" + or print "# $lines[0]\n"; + ok $lines[1] eq "and a single line.\n\n"; + } + + { + local $/ = "is"; + my $io = $UncompressClass->new($name); + my @lines = (); + my $no = 0; + my $err = 0; + ok ! $io->eof; + while (<$io>) { + push(@lines, $_); + $err++ if $. != ++$no; + } + + ok $err == 0 ; + ok $io->eof; + + ok @lines == 3 + or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; + ok join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n\n" . + "and a single line.\n\n"; + } + + + # Test read + + { + my $io = $UncompressClass->new($name); + + ok $io, "opened ok" ; + + #eval { read($io, $buf, -1); } ; + #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ; + + #eval { read($io, 1) } ; + #like $@, mkErr("buffer parameter is read-only"); + + is read($io, $buf, 0), 0, "Requested 0 bytes" ; + + ok read($io, $buf, 3) == 3 ; + ok $buf eq "Thi"; + + ok sysread($io, $buf, 3, 2) == 3 ; + ok $buf eq "Ths i" + or print "# [$buf]\n" ;; + ok ! $io->eof; + + # $io->seek(-4, 2); + # + # ok ! $io->eof; + # + # ok read($io, $buf, 20) == 4 ; + # ok $buf eq "e.\n\n"; + # + # ok read($io, $buf, 20) == 0 ; + # ok $buf eq ""; + # + # ok ! $io->eof; + } + + } + + + + { + title "seek tests" ; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $first = "beginning" ; + my $last = "the end" ; + my $iow = new $CompressClass $name ; + print $iow $first ; + ok seek $iow, 10, SEEK_CUR ; + is tell($iow), length($first)+10; + ok $iow->seek(0, SEEK_CUR) ; + is tell($iow), length($first)+10; + print $iow $last ; + close $iow; + + my $io = $UncompressClass->new($name); + ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ; + + $io = $UncompressClass->new($name); + ok seek $io, length($first)+10, SEEK_CUR ; + ok ! $io->eof; + is tell($io), length($first)+10; + ok seek $io, 0, SEEK_CUR ; + is tell($io), length($first)+10; + my $buff ; + ok read $io, $buff, 100 ; + ok $buff eq $last ; + ok $io->eof; + } + + if (! $BadPerl) + { + # seek error cases + my $b ; + my $a = new $CompressClass(\$b) ; + + ok ! $a->error() ; + eval { seek($a, -1, 10) ; }; + like $@, mkErr("^seek: unknown value, 10, for whence parameter"); + + eval { seek($a, -1, SEEK_END) ; }; + like $@, mkErr("^cannot seek backwards"); + + print $a "fred"; + close $a ; + + + my $u = new $UncompressClass(\$b) ; + + eval { seek($u, -1, 10) ; }; + like $@, mkErr("^seek: unknown value, 10, for whence parameter"); + + eval { seek($u, -1, SEEK_END) ; }; + like $@, mkErr("^seek: SEEK_END not allowed"); + + eval { seek($u, -1, SEEK_CUR) ; }; + like $@, mkErr("^cannot seek backwards"); + } + + { + title 'fileno' ; + + my $name = "test.gz" ; + my $lex = new LexFile $name ; + + my $hello = <<EOM ; +hello world +this is a test +EOM + + { + my $fh ; + ok $fh = new IO::File ">$name" ; + my $x ; + ok $x = new $CompressClass $fh ; + + ok $x->fileno() == fileno($fh) ; + ok $x->fileno() == fileno($x) ; + ok $x->write($hello) ; + ok $x->close ; + $fh->close() ; + } + + my $uncomp; + { + my $x ; + ok my $fh1 = new IO::File "<$name" ; + ok $x = new $UncompressClass $fh1, -Append => 1 ; + ok $x->fileno() == fileno $fh1 ; + ok $x->fileno() == fileno $x ; + + 1 while $x->read($uncomp) > 0 ; + + ok $x->close ; + } + + ok $hello eq $uncomp ; + } +} + diff --git a/ext/Compress/Zlib/t/22merge.t b/ext/Compress/Zlib/t/22merge.t new file mode 100644 index 0000000000..bdffaa39ee --- /dev/null +++ b/ext/Compress/Zlib/t/22merge.t @@ -0,0 +1,357 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +our ($extra); +use Compress::Zlib 2 ; + +use IO::Compress::Gzip qw($GzipError); +use IO::Uncompress::Gunzip qw($GunzipError); + +use IO::Compress::Deflate qw($DeflateError); +use IO::Uncompress::Inflate qw($InflateError); + +use IO::Compress::RawDeflate qw($RawDeflateError); +use IO::Uncompress::RawInflate qw($RawInflateError); + + +BEGIN +{ + plan(skip_all => "Merge needs Zlib 1.2.1 or better - you have Zlib " + . Compress::Zlib::zlib_version()) + if ZLIB_VERNUM() < 0x1210 ; + + # use Test::NoWarnings, if available + $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 490 + $extra ; + +} + + +# Check zlib_version and ZLIB_VERSION are the same. +is Compress::Zlib::zlib_version, ZLIB_VERSION, + "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; + +# Tests +# destination is a file that doesn't exist -- should work ok unless AnyDeflate +# destination isn't compressed at all +# destination is compressed but wrong format +# destination is corrupt - error messages should be correct +# use apend mode with old zlib - check that this is trapped +# destination is not seekable, readable, writable - test for filename & handle + +{ + title "Misc error cases"; + + eval { new Compress::Zlib::InflateScan Bufsize => 0} ; + like $@, mkErr("^Compress::Zlib::InflateScan::new: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0"; + + eval { Compress::Zlib::inflateScanStream::createDeflateStream(undef, Bufsize => 0) } ; + like $@, mkErr("^Compress::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0"; + +} + +# output file/handle not writable +foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) +{ + + my $Error = getErrorRef($CompressClass); + + foreach my $to_file (0,1) + { + if ($to_file) + { title "$CompressClass - Merge to filename that isn't writable" } + else + { title "$CompressClass - Merge to filehandle that isn't writable" } + + my $out_file = 'abcde.out'; + my $lex = new LexFile($out_file) ; + + # create empty file + open F, ">$out_file" ; print F "x"; close F; + ok -e $out_file, " file exists" ; + ok !-z $out_file, " and is not empty" ; + + # make unwritable + is chmod(0444, $out_file), 1, " chmod worked" ; + ok -e $out_file, " still exists after chmod" ; + + SKIP: + { + skip "Cannot create non-writable file", 3 + if -w $out_file ; + + ok ! -w $out_file, " chmod made file unwritable" ; + + my $dest ; + if ($to_file) + { $dest = $out_file } + else + { $dest = new IO::File "<$out_file" } + + my $gz = $CompressClass->new($dest, Merge => 1) ; + + ok ! $gz, " Did not create $CompressClass object"; + + { + if ($to_file) { + is $$Error, "Output file '$out_file' is not writable", + " Got non-writable filename message" ; + } + else { + is $$Error, "Output filehandle is not writable", + " Got non-writable filehandle message" ; + } + } + } + + chmod 0777, $out_file ; + } +} + +# output is not compressed at all +foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) +{ + + my $Error = getErrorRef($CompressClass); + + my $out_file = 'abcde.out'; + my $lex = new LexFile($out_file) ; + + foreach my $to_file ( qw(buffer file handle ) ) + { + title "$CompressClass to $to_file, content is not compressed"; + + my $content = "abc" x 300 ; + my $buffer ; + my $disp_content = defined $content ? $content : '<undef>' ; + my $str_content = defined $content ? $content : '' ; + + if ($to_file eq 'buffer') + { + $buffer = \$content ; + } + else + { + writeFile($out_file, $content); + + if ($to_file eq 'handle') + { + $buffer = new IO::File "+<$out_file" + or die "# Cannot open $out_file: $!"; + } + else + { $buffer = $out_file } + } + + ok ! $CompressClass->new($buffer, Merge => 1), " constructor fails"; + { + like $$Error, '/Cannot create InflateScan object: (Header Error|unexpected end of file)/', " got Bad Magic" ; + } + + } +} + +# output is empty +foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) +{ + + my $Error = getErrorRef($CompressClass); + + my $out_file = 'abcde.out'; + my $lex = new LexFile($out_file) ; + + foreach my $to_file ( qw(buffer file handle ) ) + { + title "$CompressClass to $to_file, content is empty"; + + my $content = ''; + my $buffer ; + my $dest ; + + if ($to_file eq 'buffer') + { + $dest = $buffer = \$content ; + } + else + { + writeFile($out_file, $content); + $dest = $out_file; + + if ($to_file eq 'handle') + { + $buffer = new IO::File "+<$out_file" + or die "# Cannot open $out_file: $!"; + } + else + { $buffer = $out_file } + } + + ok my $gz = $CompressClass->new($buffer, Merge => 1, AutoClose => 1), " constructor passes"; + + $gz->write("FGHI"); + $gz->close(); + + #hexDump($buffer); + my $out = anyUncompress($dest); + + is $out, "FGHI", ' Merge OK'; + } +} + +foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) +{ + my $Error = getErrorRef($CompressClass); + + title "$CompressClass - Merge to file that doesn't exist"; + + my $out_file = 'abcd.out'; + my $lex = new LexFile($out_file) ; + + ok ! -e $out_file, " Destination file, '$out_file', does not exist"; + + ok my $gz1 = $CompressClass->new($out_file, Merge => 1) + or die "# $CompressClass->new failed: $GzipError\n"; + #hexDump($buffer); + $gz1->write("FGHI"); + $gz1->close(); + + #hexDump($buffer); + my $out = anyUncompress($out_file); + + is $out, "FGHI", ' Merged OK'; +} + +foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) +{ + my $Error = getErrorRef($CompressClass); + + my $out_file = 'abcde.out'; + my $lex = new LexFile($out_file) ; + + foreach my $to_file ( qw( buffer file handle ) ) + { + foreach my $content (undef, '', 'x', 'abcde') + { + #next if ! defined $content && $to_file; + + my $buffer ; + my $disp_content = defined $content ? $content : '<undef>' ; + my $str_content = defined $content ? $content : '' ; + + if ($to_file eq 'buffer') + { + my $x ; + $buffer = \$x ; + title "$CompressClass to Buffer, content is '$disp_content'"; + } + else + { + $buffer = $out_file ; + if ($to_file eq 'handle') + { + title "$CompressClass to Filehandle, content is '$disp_content'"; + } + else + { + title "$CompressClass to File, content is '$disp_content'"; + } + } + + my $gz = $CompressClass->new($buffer); + my $len = defined $content ? length($content) : 0 ; + is $gz->write($content), $len, " write ok"; + ok $gz->close(), " close ok"; + + #hexDump($buffer); + is anyUncompress($buffer), $str_content, ' Destination is ok'; + + #if ($corruption) + #{ + # next if $TopTypes eq 'RawDeflate' && $content eq ''; + # + #} + + my $dest = $buffer ; + if ($to_file eq 'handle') + { + $dest = new IO::File "+<$buffer" ; + } + + my $gz1 = $CompressClass->new($dest, Merge => 1, AutoClose => 1) + or die "## $GzipError\n"; + #print "YYY\n"; + #hexDump($buffer); + #print "XXX\n"; + is $gz1->write("FGHI"), 4, " write returned 4"; + ok $gz1->close(), " close ok"; + + #hexDump($buffer); + my $out = anyUncompress($buffer); + + is $out, $str_content . "FGHI", ' Merged OK'; + #exit; + } + } + +} + + +foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) ) +{ + my $Error = getErrorRef($CompressClass); + + my $Func = getTopFuncRef($CompressClass); + my $TopType = getTopFuncName($CompressClass); + + my $buffer ; + + my $out_file = 'abcde.out'; + my $lex = new LexFile($out_file) ; + + foreach my $to_file (0, 1) + { + foreach my $content (undef, '', 'x', 'abcde') + { + my $disp_content = defined $content ? $content : '<undef>' ; + my $str_content = defined $content ? $content : '' ; + my $buffer ; + if ($to_file) + { + $buffer = $out_file ; + title "$TopType to File, content is '$disp_content'"; + } + else + { + my $x = ''; + $buffer = \$x ; + title "$TopType to Buffer, content is '$disp_content'"; + } + + + ok $Func->(\$content, $buffer), " Compress content"; + #hexDump($buffer); + is anyUncompress($buffer), $str_content, ' Destination is ok'; + + + ok $Func->(\"FGHI", $buffer, Merge => 1), " Merge content"; + + #hexDump($buffer); + my $out = anyUncompress($buffer); + + is $out, $str_content . "FGHI", ' Merged OK'; + } + } + +} + + + diff --git a/ext/Compress/Zlib/t/23misc.t b/ext/Compress/Zlib/t/23misc.t new file mode 100644 index 0000000000..f1619d8964 --- /dev/null +++ b/ext/Compress/Zlib/t/23misc.t @@ -0,0 +1,123 @@ + +use lib 't'; +use strict; +use warnings; +use bytes; + +use Test::More ; +use ZlibTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 29 + $extra ; + + + use_ok('Compress::Zlib::Common'); + + use_ok('Compress::Zlib::ParseParameters'); + +# use_ok('Compress::Zlib', 2) ; +# +# use_ok('IO::Compress::Gzip', qw($GzipError)) ; +# use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; +# +# use_ok('IO::Compress::Deflate', qw($DeflateError)) ; +# use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; +# +# use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; +# use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; +} + + +# Compress::Zlib::Common; + +sub My::testParseParameters() +{ + eval { ParseParameters(1, {}, 1) ; }; + like $@, mkErr(': Expected even number of parameters, got 1'), + "Trap odd number of params"; + + eval { ParseParameters(1, {}, undef) ; }; + like $@, mkErr(': Expected even number of parameters, got 1'), + "Trap odd number of params"; + + eval { ParseParameters(1, {}, []) ; }; + like $@, mkErr(': Expected even number of parameters, got 1'), + "Trap odd number of params"; + + eval { ParseParameters(1, {'Fred' => [Parse_unsigned, 0]}, Fred => undef) ; }; + like $@, mkErr("Parameter 'Fred' must be an unsigned int, got undef"), + "wanted unsigned, got undef"; + + eval { ParseParameters(1, {'Fred' => [Parse_signed, 0]}, Fred => undef) ; }; + like $@, mkErr("Parameter 'Fred' must be a signed int, got undef"), + "wanted signed, got undef"; + + eval { ParseParameters(1, {'Fred' => [Parse_signed, 0]}, Fred => 'abc') ; }; + like $@, mkErr("Parameter 'Fred' must be a signed int, got 'abc'"), + "wanted signed, got 'abc'"; + + my $got = ParseParameters(1, {'Fred' => [Parse_store_ref, 0]}, Fred => 'abc') ; + is ${ $got->value('Fred') }, "abc", "Parse_store_ref" ; + + $got = ParseParameters(1, {'Fred' => [0x1000000, 0]}, Fred => 'abc') ; + is $got->value('Fred'), "abc", "other" ; + +} + +My::testParseParameters(); + + +{ + title "isaFilename" ; + ok isaFilename("abc"), "'abc' isaFilename"; + + ok ! isaFilename(undef), "undef ! isaFilename"; + ok ! isaFilename([]), "[] ! isaFilename"; + $main::X = 1; $main::X = $main::X ; + ok ! isaFilename(*X), "glob ! isaFilename"; +} + +{ + title "whatIsInput" ; + + my $out_file = "abc"; + my $lex = new LexFile($out_file) ; + open FH, ">$out_file" ; + is whatIsInput(*FH), 'handle', "Match filehandle" ; + close FH ; + + my $stdin = '-'; + is whatIsInput($stdin), 'handle', "Match '-' as stdin"; + #is $stdin, \*STDIN, "'-' changed to *STDIN"; + #isa_ok $stdin, 'IO::File', "'-' changed to IO::File"; + is whatIsInput("abc"), 'filename', "Match filename"; + is whatIsInput(\"abc"), 'buffer', "Match buffer"; + is whatIsInput(sub { 1 }, 1), 'code', "Match code"; + is whatIsInput(sub { 1 }), '' , "Don't match code"; + +} + +{ + title "whatIsOutput" ; + + my $out_file = "abc"; + my $lex = new LexFile($out_file) ; + open FH, ">$out_file" ; + is whatIsOutput(*FH), 'handle', "Match filehandle" ; + close FH ; + + my $stdout = '-'; + is whatIsOutput($stdout), 'handle', "Match '-' as stdout"; + #is $stdout, \*STDOUT, "'-' changed to *STDOUT"; + #isa_ok $stdout, 'IO::File', "'-' changed to IO::File"; + is whatIsOutput("abc"), 'filename', "Match filename"; + is whatIsOutput(\"abc"), 'buffer', "Match buffer"; + is whatIsOutput(sub { 1 }, 1), 'code', "Match code"; + is whatIsOutput(sub { 1 }), '' , "Don't match code"; + +} diff --git a/ext/Compress/Zlib/t/99pod.t b/ext/Compress/Zlib/t/99pod.t new file mode 100644 index 0000000000..c86213fde2 --- /dev/null +++ b/ext/Compress/Zlib/t/99pod.t @@ -0,0 +1,9 @@ +use lib 't'; +use Test::More; + +eval "use Test::Pod 1.00"; + +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +all_pod_files_ok(); + diff --git a/ext/Compress/Zlib/t/globmapper.t b/ext/Compress/Zlib/t/globmapper.t new file mode 100644 index 0000000000..8d90e2514f --- /dev/null +++ b/ext/Compress/Zlib/t/globmapper.t @@ -0,0 +1,298 @@ + +use lib 't'; +use strict ; +use warnings ; + +use Test::More ; +use ZlibTestUtils; + + +BEGIN +{ + plan(skip_all => "File::GlobMapper needs Perl 5.005 or better - you have +Perl $]" ) + if $] < 5.005 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 68 + $extra ; + + use_ok('File::GlobMapper') ; +} + +{ + title "Error Cases" ; + + my $gm; + + for my $delim ( qw/ ( ) { } [ ] / ) + { + $gm = new File::GlobMapper("${delim}abc", '*.X'); + ok ! $gm, " new failed" ; + is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", + " catch unmatched $delim"; + } + + for my $delim ( qw/ ( ) [ ] / ) + { + $gm = new File::GlobMapper("{${delim}abc}", '*.X'); + ok ! $gm, " new failed" ; + is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", + " catch unmatched $delim inside {}"; + } + + +} + +{ + title "input glob matches zero files"; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + + my $gm = new File::GlobMapper("$tmpDir/Z*", '*.X'); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 0, " returned 0 maps"; + is_deeply $map, [], " zero maps" ; + + my $hash = $gm->getHash() ; + is_deeply $hash, {}, " zero maps" ; +} + +{ + title 'test wildcard mapping of * in destination'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/ab*.tmp", "*X"); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmpX)], + [map { "$tmpDir/$_" } qw(abc2.tmp abc2.tmpX)], + [map { "$tmpDir/$_" } qw(abc3.tmp abc3.tmpX)], + ], " got mapping"; + + my $hash = $gm->getHash() ; + is_deeply $hash, + { map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmpX + abc2.tmp abc2.tmpX + abc3.tmp abc3.tmpX), + }, " got mapping"; +} + +{ + title 'no wildcards in input or destination'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/abc2.tmp", "$tmpDir/abc2.tmp"); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 1, " returned 1 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_.tmp" } qw(abc2 abc2)], + ], " got mapping"; + + my $hash = $gm->getHash() ; + is_deeply $hash, + { map { "$tmpDir/$_.tmp" } qw(abc2 abc2), + }, " got mapping"; +} + +{ + title 'test wildcard mapping of {} in destination'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "*.X"); + #diag "Input pattern is $gm->{InputPattern}"; + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 2, " returned 2 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmp.X)], + [map { "$tmpDir/$_" } qw(abc3.tmp abc3.tmp.X)], + ], " got mapping"; + + $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "$tmpDir/X.#1.X") + or diag $File::GlobMapper::Error ; + #diag "Input pattern is $gm->{InputPattern}"; + ok $gm, " created GlobMapper object" ; + + $map = $gm->getFileMap() ; + is @{ $map }, 2, " returned 2 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X.1.X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X.3.X)], + ], " got mapping"; + +} + + +{ + title 'test wildcard mapping of multiple * to #'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/*b(*).tmp", "$tmpDir/X-#2-#1-X"); + ok $gm, " created GlobMapper object" + or diag $File::GlobMapper::Error ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], + [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], + ], " got mapping"; +} + +{ + title 'test wildcard mapping of multiple ? to #'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/?b(*).tmp", "$tmpDir/X-#2-#1-X"); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], + [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], + ], " got mapping"; +} + +{ + title 'test wildcard mapping of multiple ?,* and [] to #'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("./$tmpDir/?b[a-z]*.tmp", "./$tmpDir/X-#3-#2-#1-X"); + ok $gm, " created GlobMapper object" ; + + #diag "Input pattern is $gm->{InputPattern}"; + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "./$tmpDir/$_" } qw(abc1.tmp X-1-c-a-X)], + [map { "./$tmpDir/$_" } qw(abc2.tmp X-2-c-a-X)], + [map { "./$tmpDir/$_" } qw(abc3.tmp X-3-c-a-X)], + ], " got mapping"; +} + +{ + title 'input glob matches a file multiple times'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch "$tmpDir/abc.tmp"; + + my $gm = new File::GlobMapper("$tmpDir/{a*,*c}.tmp", '*.X'); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 1, " returned 1 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc.tmp abc.tmp.X)], ], " got mapping"; + + my $hash = $gm->getHash() ; + is_deeply $hash, + { map { "$tmpDir/$_" } qw(abc.tmp abc.tmp.X) }, " got mapping"; + +} + +{ + title 'multiple input files map to one output file'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc def) ; + + my $gm = new File::GlobMapper("$tmpDir/*.tmp", "$tmpDir/fred"); + ok ! $gm, " did not create GlobMapper object" ; + + is $File::GlobMapper::Error, 'multiple input files map to one output file', " Error is expected" ; + + #my $map = $gm->getFileMap() ; + #is @{ $map }, 1, " returned 1 maps"; + #is_deeply $map, + #[ [map { "$tmpDir/$_" } qw(abc1 abc.X)], ], " got mapping"; +} + +{ + title "globmap" ; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $map = File::GlobMapper::globmap("$tmpDir/*b*.tmp", "$tmpDir/X-#2-#1-X"); + ok $map, " got map" + or diag $File::GlobMapper::Error ; + + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], + [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], + ], " got mapping"; +} + +# TODO +# test each of the wildcard metacharacters can be mapped to the output filename +# +# ~ [] {} . * + +# input & output glob with no wildcards is ok +# input with no wild or output with no wild is bad +# input wild has concatenated *'s +# empty string for either both from & to +# escaped chars within [] and {}, including the chars []{} +# escaped , within {} +# missing ] and missing } +# {} and {,} are special cases +# {ab*,de*} +# {abc,{},{de,f}} => abc {} de f + diff --git a/ext/Compress/Zlib/typemap b/ext/Compress/Zlib/typemap index 09f0d0f81f..6d9ff17aee 100644 --- a/ext/Compress/Zlib/typemap +++ b/ext/Compress/Zlib/typemap @@ -1,17 +1,43 @@ Compress::Zlib::gzFile T_PTROBJ Compress::Zlib::deflateStream T_PTROBJ Compress::Zlib::inflateStream T_PTROBJ +Compress::Zlib::inflateScanStream T_PTROBJ Bytef * T_PV -uInt T_UV +#uInt T_IV #uLongf T_IV const char * T_PV +char * T_PV uLong T_UV +z_off_t T_UV +DualType T_DUAL +int_undef T_IV_undef + ############################################################################# INPUT T_UV $var = (unsigned long)SvUV($arg) +T_IV_undef + if (SvOK($arg)) + $var = SvIV($arg); + else + $var = 0 ; +T_PV + if (SvOK($arg)) + $var = ($type)SvPVbyte_nolen($arg); + else + $var = NULL ; + + ############################################################################# OUTPUT T_UV sv_setuv($arg, (IV)$var); + +T_DUAL + setDUALstatus($arg, $var) ; + +T_PV + sv_setpv((SV*)$arg, $var); + + diff --git a/ext/Compress/Zlib/zlib-src/gzio.c b/ext/Compress/Zlib/zlib-src/gzio.c deleted file mode 100644 index 7e90f4928f..0000000000 --- a/ext/Compress/Zlib/zlib-src/gzio.c +++ /dev/null @@ -1,1026 +0,0 @@ -/* gzio.c -- IO on .gz files - * Copyright (C) 1995-2005 Jean-loup Gailly. - * For conditions of distribution and use, see copyright notice in zlib.h - * - * Compile this file with -DNO_GZCOMPRESS to avoid the compression code. - */ - -/* @(#) $Id$ */ - -#include <stdio.h> - -#include "zutil.h" - -#ifdef NO_DEFLATE /* for compatibility with old definition */ -# define NO_GZCOMPRESS -#endif - -#ifndef NO_DUMMY_DECL -struct internal_state {int dummy;}; /* for buggy compilers */ -#endif - -#ifndef Z_BUFSIZE -# ifdef MAXSEG_64K -# define Z_BUFSIZE 4096 /* minimize memory usage for 16-bit DOS */ -# else -# define Z_BUFSIZE 16384 -# endif -#endif -#ifndef Z_PRINTF_BUFSIZE -# define Z_PRINTF_BUFSIZE 4096 -#endif - -#ifdef __MVS__ -# pragma map (fdopen , "\174\174FDOPEN") - FILE *fdopen(int, const char *); -#endif - -#ifndef STDC -extern voidp malloc OF((uInt size)); -extern void free OF((voidpf ptr)); -#endif - -#define ALLOC(size) malloc(size) -#define TRYFREE(p) {if (p) free(p);} - -static int const gz_magic[2] = {0x1f, 0x8b}; /* gzip magic header */ - -/* gzip flag byte */ -#define ASCII_FLAG 0x01 /* bit 0 set: file probably ascii text */ -#define HEAD_CRC 0x02 /* bit 1 set: header CRC present */ -#define EXTRA_FIELD 0x04 /* bit 2 set: extra field present */ -#define ORIG_NAME 0x08 /* bit 3 set: original file name present */ -#define COMMENT 0x10 /* bit 4 set: file comment present */ -#define RESERVED 0xE0 /* bits 5..7: reserved */ - -typedef struct gz_stream { - z_stream stream; - int z_err; /* error code for last stream operation */ - int z_eof; /* set if end of input file */ - FILE *file; /* .gz file */ - Byte *inbuf; /* input buffer */ - Byte *outbuf; /* output buffer */ - uLong crc; /* crc32 of uncompressed data */ - char *msg; /* error message */ - char *path; /* path name for debugging only */ - int transparent; /* 1 if input file is not a .gz file */ - char mode; /* 'w' or 'r' */ - z_off_t start; /* start of compressed data in file (header skipped) */ - z_off_t in; /* bytes into deflate or inflate */ - z_off_t out; /* bytes out of deflate or inflate */ - int back; /* one character push-back */ - int last; /* true if push-back is last character */ -} gz_stream; - - -local gzFile gz_open OF((const char *path, const char *mode, int fd)); -local int do_flush OF((gzFile file, int flush)); -local int get_byte OF((gz_stream *s)); -local void check_header OF((gz_stream *s)); -local int destroy OF((gz_stream *s)); -local void putLong OF((FILE *file, uLong x)); -local uLong getLong OF((gz_stream *s)); - -/* =========================================================================== - Opens a gzip (.gz) file for reading or writing. The mode parameter - is as in fopen ("rb" or "wb"). The file is given either by file descriptor - or path name (if fd == -1). - gz_open returns NULL if the file could not be opened or if there was - insufficient memory to allocate the (de)compression state; errno - can be checked to distinguish the two cases (if errno is zero, the - zlib error is Z_MEM_ERROR). -*/ -local gzFile gz_open (path, mode, fd) - const char *path; - const char *mode; - int fd; -{ - int err; - int level = Z_DEFAULT_COMPRESSION; /* compression level */ - int strategy = Z_DEFAULT_STRATEGY; /* compression strategy */ - char *p = (char*)mode; - gz_stream *s; - char fmode[80]; /* copy of mode, without the compression level */ - char *m = fmode; - - if (!path || !mode) return Z_NULL; - - s = (gz_stream *)ALLOC(sizeof(gz_stream)); - if (!s) return Z_NULL; - - s->stream.zalloc = (alloc_func)0; - s->stream.zfree = (free_func)0; - s->stream.opaque = (voidpf)0; - s->stream.next_in = s->inbuf = Z_NULL; - s->stream.next_out = s->outbuf = Z_NULL; - s->stream.avail_in = s->stream.avail_out = 0; - s->file = NULL; - s->z_err = Z_OK; - s->z_eof = 0; - s->in = 0; - s->out = 0; - s->back = EOF; - s->crc = crc32(0L, Z_NULL, 0); - s->msg = NULL; - s->transparent = 0; - - s->path = (char*)ALLOC(strlen(path)+1); - if (s->path == NULL) { - return destroy(s), (gzFile)Z_NULL; - } - strcpy(s->path, path); /* do this early for debugging */ - - s->mode = '\0'; - do { - if (*p == 'r') s->mode = 'r'; - if (*p == 'w' || *p == 'a') s->mode = 'w'; - if (*p >= '0' && *p <= '9') { - level = *p - '0'; - } else if (*p == 'f') { - strategy = Z_FILTERED; - } else if (*p == 'h') { - strategy = Z_HUFFMAN_ONLY; - } else if (*p == 'R') { - strategy = Z_RLE; - } else { - *m++ = *p; /* copy the mode */ - } - } while (*p++ && m != fmode + sizeof(fmode)); - if (s->mode == '\0') return destroy(s), (gzFile)Z_NULL; - - if (s->mode == 'w') { -#ifdef NO_GZCOMPRESS - err = Z_STREAM_ERROR; -#else - err = deflateInit2(&(s->stream), level, - Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, strategy); - /* windowBits is passed < 0 to suppress zlib header */ - - s->stream.next_out = s->outbuf = (Byte*)ALLOC(Z_BUFSIZE); -#endif - if (err != Z_OK || s->outbuf == Z_NULL) { - return destroy(s), (gzFile)Z_NULL; - } - } else { - s->stream.next_in = s->inbuf = (Byte*)ALLOC(Z_BUFSIZE); - - err = inflateInit2(&(s->stream), -MAX_WBITS); - /* windowBits is passed < 0 to tell that there is no zlib header. - * Note that in this case inflate *requires* an extra "dummy" byte - * after the compressed stream in order to complete decompression and - * return Z_STREAM_END. Here the gzip CRC32 ensures that 4 bytes are - * present after the compressed stream. - */ - if (err != Z_OK || s->inbuf == Z_NULL) { - return destroy(s), (gzFile)Z_NULL; - } - } - s->stream.avail_out = Z_BUFSIZE; - - errno = 0; - s->file = fd < 0 ? F_OPEN(path, fmode) : (FILE*)fdopen(fd, fmode); - - if (s->file == NULL) { - return destroy(s), (gzFile)Z_NULL; - } - if (s->mode == 'w') { - /* Write a very simple .gz header: - */ - fprintf(s->file, "%c%c%c%c%c%c%c%c%c%c", gz_magic[0], gz_magic[1], - Z_DEFLATED, 0 /*flags*/, 0,0,0,0 /*time*/, 0 /*xflags*/, OS_CODE); - s->start = 10L; - /* We use 10L instead of ftell(s->file) to because ftell causes an - * fflush on some systems. This version of the library doesn't use - * start anyway in write mode, so this initialization is not - * necessary. - */ - } else { - check_header(s); /* skip the .gz header */ - s->start = ftell(s->file) - s->stream.avail_in; - } - - return (gzFile)s; -} - -/* =========================================================================== - Opens a gzip (.gz) file for reading or writing. -*/ -gzFile ZEXPORT gzopen (path, mode) - const char *path; - const char *mode; -{ - return gz_open (path, mode, -1); -} - -/* =========================================================================== - Associate a gzFile with the file descriptor fd. fd is not dup'ed here - to mimic the behavio(u)r of fdopen. -*/ -gzFile ZEXPORT gzdopen (fd, mode) - int fd; - const char *mode; -{ - char name[46]; /* allow for up to 128-bit integers */ - - if (fd < 0) return (gzFile)Z_NULL; - sprintf(name, "<fd:%d>", fd); /* for debugging */ - - return gz_open (name, mode, fd); -} - -/* =========================================================================== - * Update the compression level and strategy - */ -int ZEXPORT gzsetparams (file, level, strategy) - gzFile file; - int level; - int strategy; -{ - gz_stream *s = (gz_stream*)file; - - if (s == NULL || s->mode != 'w') return Z_STREAM_ERROR; - - /* Make room to allow flushing */ - if (s->stream.avail_out == 0) { - - s->stream.next_out = s->outbuf; - if (fwrite(s->outbuf, 1, Z_BUFSIZE, s->file) != Z_BUFSIZE) { - s->z_err = Z_ERRNO; - } - s->stream.avail_out = Z_BUFSIZE; - } - - return deflateParams (&(s->stream), level, strategy); -} - -/* =========================================================================== - Read a byte from a gz_stream; update next_in and avail_in. Return EOF - for end of file. - IN assertion: the stream s has been sucessfully opened for reading. -*/ -local int get_byte(s) - gz_stream *s; -{ - if (s->z_eof) return EOF; - if (s->stream.avail_in == 0) { - errno = 0; - s->stream.avail_in = (uInt)fread(s->inbuf, 1, Z_BUFSIZE, s->file); - if (s->stream.avail_in == 0) { - s->z_eof = 1; - if (ferror(s->file)) s->z_err = Z_ERRNO; - return EOF; - } - s->stream.next_in = s->inbuf; - } - s->stream.avail_in--; - return *(s->stream.next_in)++; -} - -/* =========================================================================== - Check the gzip header of a gz_stream opened for reading. Set the stream - mode to transparent if the gzip magic header is not present; set s->err - to Z_DATA_ERROR if the magic header is present but the rest of the header - is incorrect. - IN assertion: the stream s has already been created sucessfully; - s->stream.avail_in is zero for the first time, but may be non-zero - for concatenated .gz files. -*/ -local void check_header(s) - gz_stream *s; -{ - int method; /* method byte */ - int flags; /* flags byte */ - uInt len; - int c; - - /* Assure two bytes in the buffer so we can peek ahead -- handle case - where first byte of header is at the end of the buffer after the last - gzip segment */ - len = s->stream.avail_in; - if (len < 2) { - if (len) s->inbuf[0] = s->stream.next_in[0]; - errno = 0; - len = (uInt)fread(s->inbuf + len, 1, Z_BUFSIZE >> len, s->file); - if (len == 0 && ferror(s->file)) s->z_err = Z_ERRNO; - s->stream.avail_in += len; - s->stream.next_in = s->inbuf; - if (s->stream.avail_in < 2) { - s->transparent = s->stream.avail_in; - return; - } - } - - /* Peek ahead to check the gzip magic header */ - if (s->stream.next_in[0] != gz_magic[0] || - s->stream.next_in[1] != gz_magic[1]) { - s->transparent = 1; - return; - } - s->stream.avail_in -= 2; - s->stream.next_in += 2; - - /* Check the rest of the gzip header */ - method = get_byte(s); - flags = get_byte(s); - if (method != Z_DEFLATED || (flags & RESERVED) != 0) { - s->z_err = Z_DATA_ERROR; - return; - } - - /* Discard time, xflags and OS code: */ - for (len = 0; len < 6; len++) (void)get_byte(s); - - if ((flags & EXTRA_FIELD) != 0) { /* skip the extra field */ - len = (uInt)get_byte(s); - len += ((uInt)get_byte(s))<<8; - /* len is garbage if EOF but the loop below will quit anyway */ - while (len-- != 0 && get_byte(s) != EOF) ; - } - if ((flags & ORIG_NAME) != 0) { /* skip the original file name */ - while ((c = get_byte(s)) != 0 && c != EOF) ; - } - if ((flags & COMMENT) != 0) { /* skip the .gz file comment */ - while ((c = get_byte(s)) != 0 && c != EOF) ; - } - if ((flags & HEAD_CRC) != 0) { /* skip the header crc */ - for (len = 0; len < 2; len++) (void)get_byte(s); - } - s->z_err = s->z_eof ? Z_DATA_ERROR : Z_OK; -} - - /* =========================================================================== - * Cleanup then free the given gz_stream. Return a zlib error code. - Try freeing in the reverse order of allocations. - */ -local int destroy (s) - gz_stream *s; -{ - int err = Z_OK; - - if (!s) return Z_STREAM_ERROR; - - TRYFREE(s->msg); - - if (s->stream.state != NULL) { - if (s->mode == 'w') { -#ifdef NO_GZCOMPRESS - err = Z_STREAM_ERROR; -#else - err = deflateEnd(&(s->stream)); -#endif - } else if (s->mode == 'r') { - err = inflateEnd(&(s->stream)); - } - } - if (s->file != NULL && fclose(s->file)) { -#ifdef ESPIPE - if (errno != ESPIPE) /* fclose is broken for pipes in HP/UX */ -#endif - err = Z_ERRNO; - } - if (s->z_err < 0) err = s->z_err; - - TRYFREE(s->inbuf); - TRYFREE(s->outbuf); - TRYFREE(s->path); - TRYFREE(s); - return err; -} - -/* =========================================================================== - Reads the given number of uncompressed bytes from the compressed file. - gzread returns the number of bytes actually read (0 for end of file). -*/ -int ZEXPORT gzread (file, buf, len) - gzFile file; - voidp buf; - unsigned len; -{ - gz_stream *s = (gz_stream*)file; - Bytef *start = (Bytef*)buf; /* starting point for crc computation */ - Byte *next_out; /* == stream.next_out but not forced far (for MSDOS) */ - - if (s == NULL || s->mode != 'r') return Z_STREAM_ERROR; - - if (s->z_err == Z_DATA_ERROR || s->z_err == Z_ERRNO) return -1; - if (s->z_err == Z_STREAM_END) return 0; /* EOF */ - - next_out = (Byte*)buf; - s->stream.next_out = (Bytef*)buf; - s->stream.avail_out = len; - - if (s->stream.avail_out && s->back != EOF) { - *next_out++ = s->back; - s->stream.next_out++; - s->stream.avail_out--; - s->back = EOF; - s->out++; - start++; - if (s->last) { - s->z_err = Z_STREAM_END; - return 1; - } - } - - while (s->stream.avail_out != 0) { - - if (s->transparent) { - /* Copy first the lookahead bytes: */ - uInt n = s->stream.avail_in; - if (n > s->stream.avail_out) n = s->stream.avail_out; - if (n > 0) { - zmemcpy(s->stream.next_out, s->stream.next_in, n); - next_out += n; - s->stream.next_out = next_out; - s->stream.next_in += n; - s->stream.avail_out -= n; - s->stream.avail_in -= n; - } - if (s->stream.avail_out > 0) { - s->stream.avail_out -= - (uInt)fread(next_out, 1, s->stream.avail_out, s->file); - } - len -= s->stream.avail_out; - s->in += len; - s->out += len; - if (len == 0) s->z_eof = 1; - return (int)len; - } - if (s->stream.avail_in == 0 && !s->z_eof) { - - errno = 0; - s->stream.avail_in = (uInt)fread(s->inbuf, 1, Z_BUFSIZE, s->file); - if (s->stream.avail_in == 0) { - s->z_eof = 1; - if (ferror(s->file)) { - s->z_err = Z_ERRNO; - break; - } - } - s->stream.next_in = s->inbuf; - } - s->in += s->stream.avail_in; - s->out += s->stream.avail_out; - s->z_err = inflate(&(s->stream), Z_NO_FLUSH); - s->in -= s->stream.avail_in; - s->out -= s->stream.avail_out; - - if (s->z_err == Z_STREAM_END) { - /* Check CRC and original size */ - s->crc = crc32(s->crc, start, (uInt)(s->stream.next_out - start)); - start = s->stream.next_out; - - if (getLong(s) != s->crc) { - s->z_err = Z_DATA_ERROR; - } else { - (void)getLong(s); - /* The uncompressed length returned by above getlong() may be - * different from s->out in case of concatenated .gz files. - * Check for such files: - */ - check_header(s); - if (s->z_err == Z_OK) { - inflateReset(&(s->stream)); - s->crc = crc32(0L, Z_NULL, 0); - } - } - } - if (s->z_err != Z_OK || s->z_eof) break; - } - s->crc = crc32(s->crc, start, (uInt)(s->stream.next_out - start)); - - if (len == s->stream.avail_out && - (s->z_err == Z_DATA_ERROR || s->z_err == Z_ERRNO)) - return -1; - return (int)(len - s->stream.avail_out); -} - - -/* =========================================================================== - Reads one byte from the compressed file. gzgetc returns this byte - or -1 in case of end of file or error. -*/ -int ZEXPORT gzgetc(file) - gzFile file; -{ - unsigned char c; - - return gzread(file, &c, 1) == 1 ? c : -1; -} - - -/* =========================================================================== - Push one byte back onto the stream. -*/ -int ZEXPORT gzungetc(c, file) - int c; - gzFile file; -{ - gz_stream *s = (gz_stream*)file; - - if (s == NULL || s->mode != 'r' || c == EOF || s->back != EOF) return EOF; - s->back = c; - s->out--; - s->last = (s->z_err == Z_STREAM_END); - if (s->last) s->z_err = Z_OK; - s->z_eof = 0; - return c; -} - - -/* =========================================================================== - Reads bytes from the compressed file until len-1 characters are - read, or a newline character is read and transferred to buf, or an - end-of-file condition is encountered. The string is then terminated - with a null character. - gzgets returns buf, or Z_NULL in case of error. - - The current implementation is not optimized at all. -*/ -char * ZEXPORT gzgets(file, buf, len) - gzFile file; - char *buf; - int len; -{ - char *b = buf; - if (buf == Z_NULL || len <= 0) return Z_NULL; - - while (--len > 0 && gzread(file, buf, 1) == 1 && *buf++ != '\n') ; - *buf = '\0'; - return b == buf && len > 0 ? Z_NULL : b; -} - - -#ifndef NO_GZCOMPRESS -/* =========================================================================== - Writes the given number of uncompressed bytes into the compressed file. - gzwrite returns the number of bytes actually written (0 in case of error). -*/ -int ZEXPORT gzwrite (file, buf, len) - gzFile file; - voidpc buf; - unsigned len; -{ - gz_stream *s = (gz_stream*)file; - - if (s == NULL || s->mode != 'w') return Z_STREAM_ERROR; - - s->stream.next_in = (Bytef*)buf; - s->stream.avail_in = len; - - while (s->stream.avail_in != 0) { - - if (s->stream.avail_out == 0) { - - s->stream.next_out = s->outbuf; - if (fwrite(s->outbuf, 1, Z_BUFSIZE, s->file) != Z_BUFSIZE) { - s->z_err = Z_ERRNO; - break; - } - s->stream.avail_out = Z_BUFSIZE; - } - s->in += s->stream.avail_in; - s->out += s->stream.avail_out; - s->z_err = deflate(&(s->stream), Z_NO_FLUSH); - s->in -= s->stream.avail_in; - s->out -= s->stream.avail_out; - if (s->z_err != Z_OK) break; - } - s->crc = crc32(s->crc, (const Bytef *)buf, len); - - return (int)(len - s->stream.avail_in); -} - - -/* =========================================================================== - Converts, formats, and writes the args to the compressed file under - control of the format string, as in fprintf. gzprintf returns the number of - uncompressed bytes actually written (0 in case of error). -*/ -#ifdef STDC -#include <stdarg.h> - -int ZEXPORTVA gzprintf (gzFile file, const char *format, /* args */ ...) -{ - char buf[Z_PRINTF_BUFSIZE]; - va_list va; - int len; - - buf[sizeof(buf) - 1] = 0; - va_start(va, format); -#ifdef NO_vsnprintf -# ifdef HAS_vsprintf_void - (void)vsprintf(buf, format, va); - va_end(va); - for (len = 0; len < sizeof(buf); len++) - if (buf[len] == 0) break; -# else - len = vsprintf(buf, format, va); - va_end(va); -# endif -#else -# ifdef HAS_vsnprintf_void - (void)vsnprintf(buf, sizeof(buf), format, va); - va_end(va); - len = strlen(buf); -# else - len = vsnprintf(buf, sizeof(buf), format, va); - va_end(va); -# endif -#endif - if (len <= 0 || len >= (int)sizeof(buf) || buf[sizeof(buf) - 1] != 0) - return 0; - return gzwrite(file, buf, (unsigned)len); -} -#else /* not ANSI C */ - -int ZEXPORTVA gzprintf (file, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, - a11, a12, a13, a14, a15, a16, a17, a18, a19, a20) - gzFile file; - const char *format; - int a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, - a11, a12, a13, a14, a15, a16, a17, a18, a19, a20; -{ - char buf[Z_PRINTF_BUFSIZE]; - int len; - - buf[sizeof(buf) - 1] = 0; -#ifdef NO_snprintf -# ifdef HAS_sprintf_void - sprintf(buf, format, a1, a2, a3, a4, a5, a6, a7, a8, - a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); - for (len = 0; len < sizeof(buf); len++) - if (buf[len] == 0) break; -# else - len = sprintf(buf, format, a1, a2, a3, a4, a5, a6, a7, a8, - a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); -# endif -#else -# ifdef HAS_snprintf_void - snprintf(buf, sizeof(buf), format, a1, a2, a3, a4, a5, a6, a7, a8, - a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); - len = strlen(buf); -# else - len = snprintf(buf, sizeof(buf), format, a1, a2, a3, a4, a5, a6, a7, a8, - a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); -# endif -#endif - if (len <= 0 || len >= sizeof(buf) || buf[sizeof(buf) - 1] != 0) - return 0; - return gzwrite(file, buf, len); -} -#endif - -/* =========================================================================== - Writes c, converted to an unsigned char, into the compressed file. - gzputc returns the value that was written, or -1 in case of error. -*/ -int ZEXPORT gzputc(file, c) - gzFile file; - int c; -{ - unsigned char cc = (unsigned char) c; /* required for big endian systems */ - - return gzwrite(file, &cc, 1) == 1 ? (int)cc : -1; -} - - -/* =========================================================================== - Writes the given null-terminated string to the compressed file, excluding - the terminating null character. - gzputs returns the number of characters written, or -1 in case of error. -*/ -int ZEXPORT gzputs(file, s) - gzFile file; - const char *s; -{ - return gzwrite(file, (char*)s, (unsigned)strlen(s)); -} - - -/* =========================================================================== - Flushes all pending output into the compressed file. The parameter - flush is as in the deflate() function. -*/ -local int do_flush (file, flush) - gzFile file; - int flush; -{ - uInt len; - int done = 0; - gz_stream *s = (gz_stream*)file; - - if (s == NULL || s->mode != 'w') return Z_STREAM_ERROR; - - s->stream.avail_in = 0; /* should be zero already anyway */ - - for (;;) { - len = Z_BUFSIZE - s->stream.avail_out; - - if (len != 0) { - if ((uInt)fwrite(s->outbuf, 1, len, s->file) != len) { - s->z_err = Z_ERRNO; - return Z_ERRNO; - } - s->stream.next_out = s->outbuf; - s->stream.avail_out = Z_BUFSIZE; - } - if (done) break; - s->out += s->stream.avail_out; - s->z_err = deflate(&(s->stream), flush); - s->out -= s->stream.avail_out; - - /* Ignore the second of two consecutive flushes: */ - if (len == 0 && s->z_err == Z_BUF_ERROR) s->z_err = Z_OK; - - /* deflate has finished flushing only when it hasn't used up - * all the available space in the output buffer: - */ - done = (s->stream.avail_out != 0 || s->z_err == Z_STREAM_END); - - if (s->z_err != Z_OK && s->z_err != Z_STREAM_END) break; - } - return s->z_err == Z_STREAM_END ? Z_OK : s->z_err; -} - -int ZEXPORT gzflush (file, flush) - gzFile file; - int flush; -{ - gz_stream *s = (gz_stream*)file; - int err = do_flush (file, flush); - - if (err) return err; - fflush(s->file); - return s->z_err == Z_STREAM_END ? Z_OK : s->z_err; -} -#endif /* NO_GZCOMPRESS */ - -/* =========================================================================== - Sets the starting position for the next gzread or gzwrite on the given - compressed file. The offset represents a number of bytes in the - gzseek returns the resulting offset location as measured in bytes from - the beginning of the uncompressed stream, or -1 in case of error. - SEEK_END is not implemented, returns error. - In this version of the library, gzseek can be extremely slow. -*/ -z_off_t ZEXPORT gzseek (file, offset, whence) - gzFile file; - z_off_t offset; - int whence; -{ - gz_stream *s = (gz_stream*)file; - - if (s == NULL || whence == SEEK_END || - s->z_err == Z_ERRNO || s->z_err == Z_DATA_ERROR) { - return -1L; - } - - if (s->mode == 'w') { -#ifdef NO_GZCOMPRESS - return -1L; -#else - if (whence == SEEK_SET) { - offset -= s->in; - } - if (offset < 0) return -1L; - - /* At this point, offset is the number of zero bytes to write. */ - if (s->inbuf == Z_NULL) { - s->inbuf = (Byte*)ALLOC(Z_BUFSIZE); /* for seeking */ - if (s->inbuf == Z_NULL) return -1L; - zmemzero(s->inbuf, Z_BUFSIZE); - } - while (offset > 0) { - uInt size = Z_BUFSIZE; - if (offset < Z_BUFSIZE) size = (uInt)offset; - - size = gzwrite(file, s->inbuf, size); - if (size == 0) return -1L; - - offset -= size; - } - return s->in; -#endif - } - /* Rest of function is for reading only */ - - /* compute absolute position */ - if (whence == SEEK_CUR) { - offset += s->out; - } - if (offset < 0) return -1L; - - if (s->transparent) { - /* map to fseek */ - s->back = EOF; - s->stream.avail_in = 0; - s->stream.next_in = s->inbuf; - if (fseek(s->file, offset, SEEK_SET) < 0) return -1L; - - s->in = s->out = offset; - return offset; - } - - /* For a negative seek, rewind and use positive seek */ - if (offset >= s->out) { - offset -= s->out; - } else if (gzrewind(file) < 0) { - return -1L; - } - /* offset is now the number of bytes to skip. */ - - if (offset != 0 && s->outbuf == Z_NULL) { - s->outbuf = (Byte*)ALLOC(Z_BUFSIZE); - if (s->outbuf == Z_NULL) return -1L; - } - if (offset && s->back != EOF) { - s->back = EOF; - s->out++; - offset--; - if (s->last) s->z_err = Z_STREAM_END; - } - while (offset > 0) { - int size = Z_BUFSIZE; - if (offset < Z_BUFSIZE) size = (int)offset; - - size = gzread(file, s->outbuf, (uInt)size); - if (size <= 0) return -1L; - offset -= size; - } - return s->out; -} - -/* =========================================================================== - Rewinds input file. -*/ -int ZEXPORT gzrewind (file) - gzFile file; -{ - gz_stream *s = (gz_stream*)file; - - if (s == NULL || s->mode != 'r') return -1; - - s->z_err = Z_OK; - s->z_eof = 0; - s->back = EOF; - s->stream.avail_in = 0; - s->stream.next_in = s->inbuf; - s->crc = crc32(0L, Z_NULL, 0); - if (!s->transparent) (void)inflateReset(&s->stream); - s->in = 0; - s->out = 0; - return fseek(s->file, s->start, SEEK_SET); -} - -/* =========================================================================== - Returns the starting position for the next gzread or gzwrite on the - given compressed file. This position represents a number of bytes in the - uncompressed data stream. -*/ -z_off_t ZEXPORT gztell (file) - gzFile file; -{ - return gzseek(file, 0L, SEEK_CUR); -} - -/* =========================================================================== - Returns 1 when EOF has previously been detected reading the given - input stream, otherwise zero. -*/ -int ZEXPORT gzeof (file) - gzFile file; -{ - gz_stream *s = (gz_stream*)file; - - /* With concatenated compressed files that can have embedded - * crc trailers, z_eof is no longer the only/best indicator of EOF - * on a gz_stream. Handle end-of-stream error explicitly here. - */ - if (s == NULL || s->mode != 'r') return 0; - if (s->z_eof) return 1; - return s->z_err == Z_STREAM_END; -} - -/* =========================================================================== - Returns 1 if reading and doing so transparently, otherwise zero. -*/ -int ZEXPORT gzdirect (file) - gzFile file; -{ - gz_stream *s = (gz_stream*)file; - - if (s == NULL || s->mode != 'r') return 0; - return s->transparent; -} - -/* =========================================================================== - Outputs a long in LSB order to the given file -*/ -local void putLong (file, x) - FILE *file; - uLong x; -{ - int n; - for (n = 0; n < 4; n++) { - fputc((int)(x & 0xff), file); - x >>= 8; - } -} - -/* =========================================================================== - Reads a long in LSB order from the given gz_stream. Sets z_err in case - of error. -*/ -local uLong getLong (s) - gz_stream *s; -{ - uLong x = (uLong)get_byte(s); - int c; - - x += ((uLong)get_byte(s))<<8; - x += ((uLong)get_byte(s))<<16; - c = get_byte(s); - if (c == EOF) s->z_err = Z_DATA_ERROR; - x += ((uLong)c)<<24; - return x; -} - -/* =========================================================================== - Flushes all pending output if necessary, closes the compressed file - and deallocates all the (de)compression state. -*/ -int ZEXPORT gzclose (file) - gzFile file; -{ - gz_stream *s = (gz_stream*)file; - - if (s == NULL) return Z_STREAM_ERROR; - - if (s->mode == 'w') { -#ifdef NO_GZCOMPRESS - return Z_STREAM_ERROR; -#else - if (do_flush (file, Z_FINISH) != Z_OK) - return destroy((gz_stream*)file); - - putLong (s->file, s->crc); - putLong (s->file, (uLong)(s->in & 0xffffffff)); -#endif - } - return destroy((gz_stream*)file); -} - -#ifdef STDC -# define zstrerror(errnum) strerror(errnum) -#else -# define zstrerror(errnum) "" -#endif - -/* =========================================================================== - Returns the error message for the last error which occurred on the - given compressed file. errnum is set to zlib error number. If an - error occurred in the file system and not in the compression library, - errnum is set to Z_ERRNO and the application may consult errno - to get the exact error code. -*/ -const char * ZEXPORT gzerror (file, errnum) - gzFile file; - int *errnum; -{ - char *m; - gz_stream *s = (gz_stream*)file; - - if (s == NULL) { - *errnum = Z_STREAM_ERROR; - return (const char*)ERR_MSG(Z_STREAM_ERROR); - } - *errnum = s->z_err; - if (*errnum == Z_OK) return (const char*)""; - - m = (char*)(*errnum == Z_ERRNO ? zstrerror(errno) : s->stream.msg); - - if (m == NULL || *m == '\0') m = (char*)ERR_MSG(s->z_err); - - TRYFREE(s->msg); - s->msg = (char*)ALLOC(strlen(s->path) + strlen(m) + 3); - if (s->msg == Z_NULL) return (const char*)ERR_MSG(Z_MEM_ERROR); - strcpy(s->msg, s->path); - strcat(s->msg, ": "); - strcat(s->msg, m); - return (const char*)s->msg; -} - -/* =========================================================================== - Clear the error and end-of-file flags, and do the same for the real file. -*/ -void ZEXPORT gzclearerr (file) - gzFile file; -{ - gz_stream *s = (gz_stream*)file; - - if (s == NULL) return; - if (s->z_err != Z_STREAM_END) s->z_err = Z_OK; - s->z_eof = 0; - clearerr(s->file); -} |