ext/Cwd/t/cwd.t See if Cwd works
ext/Cwd/t/taint.t See if Cwd works with taint
ext/Cwd/t/win32.t See if Cwd works on Win32
-ext/Compress/Zlib/ANNOUNCE Compress::Zlib
-ext/Compress/Zlib/Makefile.PL Compress::Zlib
-ext/Compress/Zlib/README Compress::Zlib
ext/Compress/Zlib/Changes Compress::Zlib
-ext/Compress/Zlib/Zlib.pm Compress::Zlib
-ext/Compress/Zlib/Zlib.xs Compress::Zlib
ext/Compress/Zlib/config.in Compress::Zlib
ext/Compress/Zlib/examples/filtdef Compress::Zlib
ext/Compress/Zlib/examples/filtinf Compress::Zlib
ext/Compress/Zlib/examples/gzcat Compress::Zlib
+ext/Compress/Zlib/examples/gzcat.zlib Compress::Zlib
ext/Compress/Zlib/examples/gzgrep Compress::Zlib
ext/Compress/Zlib/examples/gzstream Compress::Zlib
-ext/Compress/Zlib/fallback.h Compress::Zlib
-ext/Compress/Zlib/fallback.xs Compress::Zlib
-ext/Compress/Zlib/t/01version.t Compress::Zlib
-ext/Compress/Zlib/t/02zlib.t Compress::Zlib
-ext/Compress/Zlib/t/03examples.t Compress::Zlib
-ext/Compress/Zlib/t/04encoding.t Compress::Zlib
-ext/Compress/Zlib/t/05gzsetp.t Compress::Zlib
-ext/Compress/Zlib/t/06gzdopen.t Compress::Zlib
-ext/Compress/Zlib/typemap Compress::Zlib
+ext/Compress/Zlib/fallback/constants.h Compress::Zlib
+ext/Compress/Zlib/fallback/constants.xs Compress::Zlib
+ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm Compress::Zlib
+ext/Compress/Zlib/lib/Compress/Zlib/Common.pm Compress::Zlib
+ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm Compress::Zlib
+ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm Compress::Zlib
+ext/Compress/Zlib/lib/File/GlobMapper.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Compress/Deflate.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Compress/Gzip.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Compress/RawDeflate.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Uncompress/Inflate.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm Compress::Zlib
+ext/Compress/Zlib/Makefile.PL Compress::Zlib
+ext/Compress/Zlib/pod/FAQ.pod Compress::Zlib
+ext/Compress/Zlib/ppport.h Compress::Zlib
+ext/Compress/Zlib/README Compress::Zlib
+ext/Compress/Zlib/t/01version.t Compress::Zlib
+ext/Compress/Zlib/t/02zlib.t Compress::Zlib
+ext/Compress/Zlib/t/03zlib-v1.t Compress::Zlib
+ext/Compress/Zlib/t/04def.t Compress::Zlib
+ext/Compress/Zlib/t/05examples.t Compress::Zlib
+ext/Compress/Zlib/t/06gzsetp.t Compress::Zlib
+ext/Compress/Zlib/t/07bufsize.t Compress::Zlib
+ext/Compress/Zlib/t/08encoding.t Compress::Zlib
+ext/Compress/Zlib/t/09gziphdr.t Compress::Zlib
+ext/Compress/Zlib/t/10defhdr.t Compress::Zlib
+ext/Compress/Zlib/t/11truncate.t Compress::Zlib
+ext/Compress/Zlib/t/12any.t Compress::Zlib
+ext/Compress/Zlib/t/13prime.t Compress::Zlib
+ext/Compress/Zlib/t/14gzopen.t Compress::Zlib
+ext/Compress/Zlib/t/15multi.t Compress::Zlib
+ext/Compress/Zlib/t/16oneshot.t Compress::Zlib
+ext/Compress/Zlib/t/17isize.t Compress::Zlib
+ext/Compress/Zlib/t/18lvalue.t Compress::Zlib
+ext/Compress/Zlib/t/19destroy.t Compress::Zlib
+ext/Compress/Zlib/t/20tied.t Compress::Zlib
+ext/Compress/Zlib/t/21newtied.t Compress::Zlib
+ext/Compress/Zlib/t/22merge.t Compress::Zlib
+ext/Compress/Zlib/t/23misc.t Compress::Zlib
+ext/Compress/Zlib/t/99pod.t Compress::Zlib
+ext/Compress/Zlib/t/globmapper.t Compress::Zlib
+ext/Compress/Zlib/typemap Compress::Zlib
+ext/Compress/Zlib/Zlib.pm Compress::Zlib
ext/Compress/Zlib/zlib-src/adler32.c Compress::Zlib
ext/Compress/Zlib/zlib-src/compress.c Compress::Zlib
ext/Compress/Zlib/zlib-src/crc32.c Compress::Zlib
ext/Compress/Zlib/zlib-src/crc32.h Compress::Zlib
ext/Compress/Zlib/zlib-src/deflate.c Compress::Zlib
ext/Compress/Zlib/zlib-src/deflate.h Compress::Zlib
-ext/Compress/Zlib/zlib-src/gzio.c Compress::Zlib
ext/Compress/Zlib/zlib-src/infback.c Compress::Zlib
ext/Compress/Zlib/zlib-src/inffast.c Compress::Zlib
ext/Compress/Zlib/zlib-src/inffast.h Compress::Zlib
ext/Compress/Zlib/zlib-src/trees.h Compress::Zlib
ext/Compress/Zlib/zlib-src/uncompr.c Compress::Zlib
ext/Compress/Zlib/zlib-src/zconf.h Compress::Zlib
-ext/Compress/Zlib/zlib-src/zlib.h Compress::Zlib
+ext/Compress/Zlib/zlib-src/zlib.h Compress::Zlib
ext/Compress/Zlib/zlib-src/zutil.c Compress::Zlib
ext/Compress/Zlib/zlib-src/zutil.h Compress::Zlib
+ext/Compress/Zlib/Zlib.xs Compress::Zlib
ext/Data/Dumper/Changes Data pretty printer, changelog
ext/Data/Dumper/Dumper.pm Data pretty printer, module
ext/Data/Dumper/Dumper.xs Data pretty printer, externals
lib/warnings.pm For "use warnings"
lib/warnings/register.pm For "use warnings::register"
lib/warnings.t See if warning controls work
+lib/ZlibTestUtils.pm Compress::Zlib
locale.c locale-specific utility functions
makeaperl.SH perl script that produces a new perl binary
makedef.pl Create symbol export lists for linking
+++ /dev/null
- 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
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
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
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=..."
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
require 5.004 ;
use ExtUtils::MakeMaker 5.16 ;
-use Config ;
+use Config qw(%Config) ;
use File::Copy ;
BEGIN
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 ;
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)
Z_BEST_COMPRESSION
Z_BEST_SPEED
Z_BINARY
+ Z_BLOCK
Z_BUF_ERROR
Z_DATA_ERROR
Z_DEFAULT_COMPRESSION
Z_ERRNO
Z_FILTERED
Z_FINISH
+ Z_FIXED
Z_FULL_FLUSH
Z_HUFFMAN_ONLY
Z_MEM_ERROR
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
);
}
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
(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;
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' ;
$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;
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
{
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
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) {
my $vars = join ', ', split ' ', $2;
$_ = "${indent}our ($vars);\n";
}
+ elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/)
+ {
+ $_ = "$1$2\n";
+ }
};
}
my $our_sub = shift;
my $warn_sub = shift;
+ return if -d $_[0];
+
local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak";
local (@ARGV) = shift;
# 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
);
}
}
+
+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
+
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
-----------
http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz
+
+
PREREQUISITES
-------------
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
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
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
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
-
Solaris build fails with "language optional software package not installed"
---------------------------------------------------------------------------
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.
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
-----------
-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
--------
-# 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;
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/.*:://;
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 ;
- return (! ref $name and UNIVERSAL::isa(\$name, 'SCALAR')) ;
+ 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 ;
+ }
+
+ _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 Compress::Zlib::gzFile::gzread
+{
+ my $self = shift ;
+
+ return _set_gzerr(Z_STREAM_ERROR())
+ if $self->[1] ne 'inflate';
+
+ return 0 if $self->gzeof();
+
+ my $gz = $self->[0] ;
+ my $status = $gz->read($_[0], defined $_[1] ? $_[1] : 4096) ;
+ $_[0] = "" if ! defined $_[0] ;
+ _save_gzerr($gz, 1);
+ return $status ;
}
-sub ParseParameters($@)
+sub Compress::Zlib::gzFile::gzreadline
{
- 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) {
+ my $gz = $self->[0] ;
+ $_[0] = $gz->getline() ;
+ _save_gzerr($gz, 1);
+ return defined $_[0] ? length $_[0] : 0 ;
+}
- croak "$sub: parameter is not a reference to a hash"
- if ref $rest[0] ne "HASH" ;
+sub Compress::Zlib::gzFile::gzwrite
+{
+ my $self = shift ;
+ my $gz = $self->[0] ;
- %options = %{ $rest[0] } ;
- }
- elsif (@rest >= 2) {
- my $count = @rest;
- croak "$sub: Expected even number of parameters, got $count"
- if @rest % 2 != 0 ;
- %options = @rest ;
- }
+ return _set_gzerr(Z_STREAM_ERROR())
+ if $self->[1] ne 'deflate';
- while (($key, $value) = each %options)
- {
- $key =~ s/^-// ;
+ my $status = $gz->write($_[0]) ;
+ _save_gzerr($gz);
+ return $status ;
+}
- if (exists $default->{$key})
- { $got{$key} = $value }
- else
- { push (@Bad, $key) }
- }
-
- if (@Bad) {
- my ($bad) = join(", ", @Bad) ;
- croak "unknown key value(s) @Bad" ;
+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 $self = shift ;
+ my $gz = $self->[0] ;
+
+ return 0
+ if $self->[1] ne 'inflate';
+
+ my $status = $gz->eof() ;
+ _save_gzerr($gz);
+ return $status ;
+}
+
+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 ($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 $Compress::Zlib::gzerrno ;
}
-sub inflateInit(@)
+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] ;
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()) {
-
- ($output, $err) = $x->deflate($in) ;
- return undef unless $err == Z_OK() ;
+ $err = $x->deflate($in, $output) ;
+ 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 ;
}
# 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();
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();
{
$$string = '';
}
-
return $output;
}
=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) ;
$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) ;
$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>.
-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.
+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.
-=head1 DEFLATE
+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.
-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.
+Each of these areas will be discussed separately below.
-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.
-Here is a definition of the interface available:
+=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.
-=head2 B<($d, $status) = deflateInit( [OPT] )>
+If you are upgrading from C<Compress::Zlib> 1.x, the following enhancements
+have been made to the C<gzopen> interface:
-Initialises a deflation stream.
+=over 5
-It combines the features of the I<zlib> functions B<deflateInit>,
-B<deflateInit2> and B<deflateSetDictionary>.
+=item 1
-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 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>.
-If not successful, the returned deflation stream (B<$d>) will be
-I<undef> and B<$status> will hold the exact I<zlib> error code.
+=item 2
-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.
+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.
-For backward compatibility, it is also possible to pass the parameters
-as a reference to a hash containing the name=>value pairs.
+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.
-The function takes one optional parameter, a reference to a hash. The
-contents of the hash allow the deflation interface to be tailored.
+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.
-Here is a list of the valid options:
+=item 3
-=over 5
+Addition of C<gzseek> to provide a restricted C<seek> interface.
-=item B<-Level>
+=item 4.
-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>.
+Added C<gztell>.
-The default is C<-Level =E<gt>Z_DEFAULT_COMPRESSION>.
+=back
-=item B<-Method>
+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.
-Defines the compression method. The only valid value at present (and
-the default) is C<-Method =E<gt>Z_DEFLATED>.
+=over 5
-=item B<-WindowBits>
+=item B<$gz = gzopen($filename, $mode)>
-For a definition of the meaning and valid values for B<WindowBits>
-refer to the I<zlib> documentation for I<deflateInit2>.
+=item B<$gz = gzopen($filehandle, $mode)>
-Defaults to C<-WindowBits =E<gt>MAX_WBITS>.
+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.
-=item B<-MemLevel>
+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.
-For a definition of the meaning and valid values for B<MemLevel>
-refer to the I<zlib> documentation for I<deflateInit2>.
+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.
-Defaults to C<-MemLevel =E<gt>MAX_MEM_LEVEL>.
+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.
-=item B<-Strategy>
+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.
-Defines the strategy used to tune the compression. The valid values are
-C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>.
+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.
-The default is C<-Strategy =E<gt>Z_DEFAULT_STRATEGY>.
+Refer to the I<zlib> documentation for the exact format of the C<$mode>
+parameter.
-=item B<-Dictionary>
-When a dictionary is specified I<Compress::Zlib> will automatically
-call B<deflateSetDictionary> directly after calling B<deflateInit>. The
-Adler32 value for the dictionary can be obtained by calling the method
-C<$d->dict_adler()>.
+=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)
+
+These functions allow checksums to be merged.
+
+=head1 Compress::Zlib::Deflate
+
+This section defines an interface that allows in-memory compression using
+the I<deflate> interface provided by zlib.
+
+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) = new Compress::Zlib::Deflate( [OPT] ) >
+
+Initialises a deflation object.
+
+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 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 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
+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.
+
+Below is a list of the valid options:
+
+=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>.
+
+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>.
+
+=item 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>.
+
+=item 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>.
+
+=item B<-Strategy>
+
+Defines the strategy used to tune the compression. The valid values are
+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 C<deflateSetDictionary> directly after calling C<deflateInit>. The
+Adler32 value for the dictionary can be obtained by calling the method
+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
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>
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.
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" ;
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.
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.
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 = '' ;
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 ;
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] )>
-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>.
+Initialises a deflation stream.
+
+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, 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 two Perl subs defined below provide the equivalent
-functionality.
+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>
+
+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()>.
-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.
+The default is no dictionary.
-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.
+=item B<-Bufsize>
-=item B<$bytesread = $gz-E<gt>gzread($buffer [, $size]) ;>
+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>.
-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.
+The default is 4096.
-Returns the number of bytes actually read. On EOF it returns 0 and in
-the case of an error, -1.
+=back
-=item B<$bytesread = $gz-E<gt>gzreadline($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.
-Reads the next line from the compressed file into B<$line>.
+ deflateInit( -Bufsize => 300,
+ -Level => Z_BEST_SPEED ) ;
-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 B<gzread> and B<gzreadline>.
+=head2 B<($out, $status) = $d-E<gt>deflate($buffer)>
-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'>.
-=item B<$byteswritten = $gz-E<gt>gzwrite($buffer) ;>
+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>.
-Writes the contents of B<$buffer> to the compressed file. Returns the
-number of bytes actually written, or 0 on error.
+On error, C<$out> will be I<undef> and C<$status> will contain the
+I<zlib> error code.
-=item B<$status = $gz-E<gt>gzflush($flush) ;>
+In a scalar context C<deflate> will return C<$out> only.
-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.
+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.
-Returns C<Z_OK> if B<$flush> is C<Z_FINISH> and all output could be
-flushed. Otherwise the zlib error code is returned.
-Refer to the I<zlib> documentation for the valid values of B<$flush>.
+=head2 B<($out, $status) = $d-E<gt>flush([flush_type])>
-=item B<$status = $gz-E<gt>gzeof() ;>
+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.
-Returns 1 if the end of file has been detected while reading the input
-file, otherwise returns 0.
+In a scalar context C<flush> will return C<$out> only.
-=item B<$gz-E<gt>gzclose>
+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>).
-Closes the compressed file. Any pending data is flushed to the file
-before it is closed.
+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.
-=item B<$gz-E<gt>gzsetparams($level, $strategy>
+=head2 B<$status = $d-E<gt>deflateParams([OPT])>
-Change settings for the deflate stream C<$gz>.
+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.
+
+
+
+
+
/* 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
*
*/
-/* 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"
#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
-#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 ))
+#ifndef SvPVbyte_nolen
+# define SvPVbyte_nolen SvPV_nolen
+#endif
+
+#ifndef SvPVbyte
+# define SvPVbyte SvPV
+#endif
+
+#ifndef dTHX
+# define dTHX
+#endif
+
+#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 ;
+
+#define GZERRNO "Compress::Zlib::gzerrno"
-/* typedef gzFile Compress__Zlib__gzFile ; */
-typedef struct gzType {
- gzFile gz ;
- SV * buffer ;
- uLong offset ;
- bool closed ;
-} gzType ;
+#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
-typedef gzType* Compress__Zlib__gzFile ;
+#if defined(AMIGA) || defined(AMIGAOS)
+# define OS_CODE 0x01
+#endif
+
+#if defined(VAXC) || defined(VMS)
+# define OS_CODE 0x02
+#endif
+#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
+#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
-#define GZERRNO "Compress::Zlib::gzerrno"
+#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
-#define ZMALLOC(to, typ) ((to = (typ *)safemalloc(sizeof(typ))), \
- Zero(to,1,typ))
+#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 */
"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
#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)
int error_no ;
#endif
{
-#ifdef dTHX
- dTHX;
-#endif
char * errstr ;
SV * gzerror_sv = perl_get_sv(GZERRNO, FALSE) ;
}
+
static void
#ifdef CAN_PROTOTYPE
SetGzError(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)
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)
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
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) ;
}
+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()
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
-
+MODULE = Compress::Zlib PACKAGE = Compress::Zlib PREFIX = Zip_
-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
+#define Zip_adler32(buf, adler) adler32(adler, buf, (uInt)len)
+uLong
+Zip_adler32(buf, adler=adlerInitial)
+ uLong adler = NO_INIT
+ STRLEN len = NO_INIT
+ Bytef * buf = NO_INIT
+ SV * sv = ST(0) ;
+ INIT:
+ /* If the buffer is a reference, dereference it */
+ sv = deRef(sv, "adler32") ;
+#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) ;
-MODULE = Compress::Zlib PACKAGE = Compress::Zlib::gzFile PREFIX = Zip_
+ if (items < 2)
+ adler = adlerInitial;
+ else if (SvOK(ST(1)))
+ adler = SvUV(ST(1)) ;
+ else
+ adler = adlerInitial;
+
+#define Zip_crc32(buf, crc) crc32(crc, buf, (uInt)len)
-#define Zip_gzread(file, buf, len) gzread(file->gz, bufp, len)
+uLong
+Zip_crc32(buf, crc=crcInitial)
+ uLong crc = NO_INIT
+ STRLEN len = NO_INIT
+ Bytef * buf = NO_INIT
+ SV * sv = ST(0) ;
+ INIT:
+ /* If the buffer is a reference, dereference it */
+ sv = deRef(sv, "crc32") ;
+#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) ;
-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) ;
+ if (items < 2)
+ crc = crcInitial;
+ else if (SvOK(ST(1)))
+ crc = SvUV(ST(1)) ;
+ else
+ crc = crcInitial;
-#define Zip_gzeof(file) gzeof(file->gz)
-int
-Zip_gzeof(file)
- Compress::Zlib::gzFile file
+uLong
+crc32_combine(crc1, crc2, len2)
+ uLong crc1
+ uLong crc2
+ z_off_t len2
CODE:
-#ifdef OLD_ZLIB
- croak("gzeof needs zlib 1.0.6 or better") ;
+#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 = gzeof(file->gz);
+ RETVAL = crc32_combine(crc1, crc2, len2);
#endif
- OUTPUT:
- RETVAL
+ 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
+uLong
+adler32_combine(adler1, adler2, len2)
+ uLong adler1
+ uLong adler2
+ z_off_t len2
CODE:
-#ifdef OLD_ZLIB
- croak("gzsetparams needs zlib 1.0.6 or better") ;
+#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 = gzsetparams(file->gz, level, strategy);
+ RETVAL = adler32_combine(adler1, adler2, len2);
#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
-Zip_adler32(buf, adler=adlerInitial)
- uLong adler = NO_INIT
- STRLEN len = NO_INIT
- Bytef * buf = NO_INIT
- SV * sv = ST(0) ;
- INIT:
- /* If the buffer is a reference, dereference it */
- sv = deRef(sv, "adler32") ;
- buf = (Byte*)SvPV(sv, len) ;
+ OUTPUT:
+ RETVAL
- if (items < 2)
- adler = adlerInitial;
- else if (SvOK(ST(1)))
- adler = SvUV(ST(1)) ;
- else
- adler = adlerInitial;
-
-#define Zip_crc32(buf, crc) crc32(crc, buf, (uInt)len)
-
-uLong
-Zip_crc32(buf, crc=crcInitial)
- uLong crc = NO_INIT
- STRLEN len = NO_INIT
- Bytef * buf = NO_INIT
- SV * sv = ST(0) ;
- INIT:
- /* If the buffer is a reference, dereference it */
- sv = deRef(sv, "crc32") ;
- buf = (Byte*)SvPV(sv, len) ;
-
- if (items < 2)
- crc = crcInitial;
- else if (SvOK(ST(1)))
- crc = SvUV(ST(1)) ;
- else
- crc = crcInitial;
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;
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 ;
}
Safefree(s) ;
s = NULL ;
}
+ else
+ PostInitStream(s, flags, bufsize, windowBits) ;
}
else
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 ;
/* 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) ;
+ }
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;
-- 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;
-- 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
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
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)
Compress::Zlib::deflateStream 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
total_out(s)
Compress::Zlib::deflateStream s
CODE:
- RETVAL = s->stream.total_out ;
+ RETVAL = s->stream.total_out ;
OUTPUT:
RETVAL
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
-void
-inflate (s, buf)
+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
+
+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
/* 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 */
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)
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:
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
total_out(s)
Compress::Zlib::inflateStream s
CODE:
- RETVAL = s->stream.total_out ;
+ RETVAL = s->stream.total_out ;
OUTPUT:
RETVAL
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
+
# 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
#!/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 ;
#!/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 ;
#!/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() ;
}
+
--- /dev/null
+#!/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() ;
+}
-#!/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" ;
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" ;
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;
}
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;
#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;
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"});
#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
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+
+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;
--- /dev/null
+
+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;
+
--- /dev/null
+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.
--- /dev/null
+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.
+
+
+
+
--- /dev/null
+
+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.
+
+
+
+
--- /dev/null
+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.
+
+
+
+
--- /dev/null
+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.
+
+
+
--- /dev/null
+
+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.
+
+
+
--- /dev/null
+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.
+
+
+
--- /dev/null
+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.
+
+
+
--- /dev/null
+
+=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.
+
+
+
+
+
--- /dev/null
+#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 */
+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
+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
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)
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 ;
}
+
--- /dev/null
+
+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) ;
+
+ }
+}
+
+
+
+
--- /dev/null
+
+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";
+#
+#
+# }
+#
+# }
+}
+
+
+
+
+
+
+++ /dev/null
-
-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)) ;
-
-}
-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";
my $stderr = "err.out" ;
unlink $stderr ;
+unlink $file1, $file2 ;
+
my $gz = gzopen($file1, "wb");
$gz->gzwrite($hello1);
$gz->gzclose();
$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 ;
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 $_ } ;
}
+
+++ /dev/null
-
-
-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 ;
-}
-
+++ /dev/null
-
-
-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) ;
-
-}
-
--- /dev/null
+
+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 ;
+}
--- /dev/null
+
+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" ;
+
+}
--- /dev/null
+
+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
+
--- /dev/null
+
+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 ;
+ }
+
+ }
+}
+
+
+
--- /dev/null
+
+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 ;
+ }
+}
+
--- /dev/null
+
+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();
+ }
+ }
+
+}
+
--- /dev/null
+
+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 ;
+}
--- /dev/null
+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() ;
+ }
+ }
+ }
+}
--- /dev/null
+
+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");
+}
--- /dev/null
+
+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
--- /dev/null
+
+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
+
--- /dev/null
+
+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 ;
+ }
+}
+
--- /dev/null
+
+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;
+
+}
+
+
--- /dev/null
+
+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 ;
+ }
+}
+
--- /dev/null
+
+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;
+ }
+ }
+ }
+ }
+
+}
--- /dev/null
+
+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 ;
+ }
+}
+
--- /dev/null
+
+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';
+ }
+ }
+
+}
+
+
+
--- /dev/null
+
+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";
+
+}
--- /dev/null
+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();
+
--- /dev/null
+
+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
+
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);
+
+
+++ /dev/null
-/* 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);
-}
--- /dev/null
+package ZlibTestUtils;
+
+package main ;
+
+use strict ;
+use warnings;
+
+use Carp ;
+
+
+sub title
+{
+ #diag "" ;
+ ok 1, $_[0] ;
+ #diag "" ;
+}
+
+sub like_eval
+{
+ like $@, @_ ;
+}
+
+{
+ package LexFile ;
+
+ our ($index);
+ $index = '00000';
+
+ sub new
+ {
+ my $self = shift ;
+ foreach (@_)
+ {
+ # autogenerate the name unless if none supplied
+ $_ = "tst" . $index ++ . ".tmp"
+ unless defined $_;
+ }
+ chmod 0777, @_;
+ unlink @_ ;
+ bless [ @_ ], $self ;
+ }
+
+ sub DESTROY
+ {
+ my $self = shift ;
+ chmod 0777, @{ $self } ;
+ unlink @{ $self } ;
+ }
+
+}
+
+{
+ package LexDir ;
+
+ use File::Path;
+ sub new
+ {
+ my $self = shift ;
+ foreach (@_) { rmtree $_ }
+ bless [ @_ ], $self ;
+ }
+
+ sub DESTROY
+ {
+ my $self = shift ;
+ foreach (@$self) { rmtree $_ }
+ }
+}
+sub readFile
+{
+ my $f = shift ;
+
+ my @strings ;
+
+ if (Compress::Zlib::Common::isaFilehandle($f))
+ {
+ my $pos = tell($f);
+ seek($f, 0,0);
+ @strings = <$f> ;
+ seek($f, 0, $pos);
+ }
+ else
+ {
+ open (F, "<$f")
+ or die "Cannot open $f: $!\n" ;
+ @strings = <F> ;
+ close F ;
+ }
+
+ return @strings if wantarray ;
+ return join "", @strings ;
+}
+
+sub touch
+{
+ foreach (@_) { writeFile($_, '') }
+}
+
+sub writeFile
+{
+ my($filename, @strings) = @_ ;
+ open (F, ">$filename")
+ or die "Cannot open $filename: $!\n" ;
+ binmode F;
+ foreach (@strings) {
+ no warnings ;
+ print F $_ ;
+ }
+ close F ;
+}
+
+sub GZreadFile
+{
+ my ($filename) = shift ;
+
+ my ($uncomp) = "" ;
+ my $line = "" ;
+ my $fil = gzopen($filename, "rb")
+ or die "Cannopt open '$filename': $Compress::Zlib::gzerrno" ;
+
+ $uncomp .= $line
+ while $fil->gzread($line) > 0;
+
+ $fil->gzclose ;
+ return $uncomp ;
+}
+
+sub hexDump
+{
+ my $d = shift ;
+
+ if (Compress::Zlib::Common::isaFilehandle($d))
+ {
+ $d = readFile($d);
+ }
+ elsif (Compress::Zlib::Common::isaFilename($d))
+ {
+ $d = readFile($d);
+ }
+ else
+ {
+ $d = $$d ;
+ }
+
+ my $offset = 0 ;
+
+ $d = '' unless defined $d ;
+ #while (read(STDIN, $data, 16)) {
+ while (my $data = substr($d, 0, 16)) {
+ substr($d, 0, 16) = '' ;
+ printf "# %8.8lx ", $offset;
+ $offset += 16;
+
+ my @array = unpack('C*', $data);
+ foreach (@array) {
+ printf('%2.2x ', $_);
+ }
+ print " " x (16 - @array)
+ if @array < 16 ;
+ $data =~ tr/\0-\37\177-\377/./;
+ print " $data\n";
+ }
+
+}
+
+sub readHeaderInfo
+{
+ my $name = shift ;
+ my %opts = @_ ;
+
+ my $string = <<EOM;
+some text
+EOM
+
+ ok my $x = new IO::Compress::Gzip $name, %opts
+ or diag "GzipError is $IO::Compress::Gzip::GzipError" ;
+ ok $x->write($string) ;
+ ok $x->close ;
+
+ ok GZreadFile($name) eq $string ;
+
+ ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0
+ or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ;
+ ok my $hdr = $gunz->getHeaderInfo();
+ my $uncomp ;
+ ok $gunz->read($uncomp) ;
+ ok $uncomp eq $string;
+ ok $gunz->close ;
+
+ return $hdr ;
+}
+
+sub cmpFile
+{
+ my ($filename, $uue) = @_ ;
+ return readFile($filename) eq unpack("u", $uue) ;
+}
+
+sub uncompressBuffer
+{
+ my $compWith = shift ;
+ my $buffer = shift ;
+
+ my %mapping = ( 'IO::Compress::Gzip' => 'IO::Uncompress::Gunzip',
+ 'IO::Compress::Gzip::gzip' => 'IO::Uncompress::Gunzip',
+ 'IO::Compress::Deflate' => 'IO::Uncompress::Inflate',
+ 'IO::Compress::Deflate::deflate' => 'IO::Uncompress::Inflate',
+ 'IO::Compress::RawDeflate' => 'IO::Uncompress::RawInflate',
+ 'IO::Compress::RawDeflate::rawdeflate' => 'IO::Uncompress::RawInflate',
+ );
+
+ my $out ;
+ my $obj = $mapping{$compWith}->new( \$buffer, -Append => 1);
+ 1 while $obj->read($out) > 0 ;
+ return $out ;
+
+}
+
+my %ErrorMap = ( 'IO::Compress::Gzip' => \$IO::Compress::Gzip::GzipError,
+ 'IO::Compress::Gzip::gzip' => \$IO::Compress::Gzip::GzipError,
+ 'IO::Uncompress::Gunzip' => \$IO::Uncompress::Gunzip::GunzipError,
+ 'IO::Uncompress::Gunzip::gunzip' => \$IO::Uncompress::Gunzip::GunzipError,
+ 'IO::Uncompress::Inflate' => \$IO::Uncompress::Inflate::InflateError,
+ 'IO::Uncompress::Inflate::inflate' => \$IO::Uncompress::Inflate::InflateError,
+ 'IO::Compress::Deflate' => \$IO::Compress::Deflate::DeflateError,
+ 'IO::Compress::Deflate::deflate' => \$IO::Compress::Deflate::DeflateError,
+ 'IO::Uncompress::RawInflate' => \$IO::Uncompress::RawInflate::RawInflateError,
+ 'IO::Uncompress::RawInflate::rawinflate' => \$IO::Uncompress::RawInflate::RawInflateError,
+ 'IO::Uncompress::AnyInflate' => \$IO::Uncompress::AnyInflate::AnyInflateError,
+ 'IO::Uncompress::AnyInflate::anyinflate' => \$IO::Uncompress::AnyInflate::AnyInflateError,
+ 'IO::Compress::RawDeflate' => \$IO::Compress::RawDeflate::RawDeflateError,
+ 'IO::Compress::RawDeflate::rawdeflate' => \$IO::Compress::RawDeflate::RawDeflateError,
+ );
+
+my %TopFuncMap = ( 'IO::Compress::Gzip' => 'IO::Compress::Gzip::gzip',
+ 'IO::Uncompress::Gunzip' => 'IO::Uncompress::Gunzip::gunzip',
+ 'IO::Compress::Deflate' => 'IO::Compress::Deflate::deflate',
+ 'IO::Uncompress::Inflate' => 'IO::Uncompress::Inflate::inflate',
+ 'IO::Compress::RawDeflate' => 'IO::Compress::RawDeflate::rawdeflate',
+ 'IO::Uncompress::RawInflate' => 'IO::Uncompress::RawInflate::rawinflate',
+ 'IO::Uncompress::AnyInflate' => 'IO::Uncompress::AnyInflate::anyinflate',
+ );
+
+ %TopFuncMap = map { ($_ => $TopFuncMap{$_},
+ $TopFuncMap{$_} => $TopFuncMap{$_}) }
+ keys %TopFuncMap ;
+
+ #%TopFuncMap = map { ($_ => \&{ $TopFuncMap{$_} ) }
+ #keys %TopFuncMap ;
+
+
+my %inverse = ( 'IO::Compress::Gzip' => 'IO::Uncompress::Gunzip',
+ 'IO::Compress::Gzip::gzip' => 'IO::Uncompress::Gunzip::gunzip',
+ 'IO::Compress::Deflate' => 'IO::Uncompress::Inflate',
+ 'IO::Compress::Deflate::deflate' => 'IO::Uncompress::Inflate::inflate',
+ 'IO::Compress::RawDeflate' => 'IO::Uncompress::RawInflate',
+ 'IO::Compress::RawDeflate::rawdeflate' => 'IO::Uncompress::RawInflate::rawinflate',
+ );
+
+%inverse = map { ($_ => $inverse{$_}, $inverse{$_} => $_) } keys %inverse;
+
+sub getInverse
+{
+ my $class = shift ;
+
+ return $inverse{$class} ;
+}
+
+sub getErrorRef
+{
+ my $class = shift ;
+
+ return $ErrorMap{$class} ;
+}
+
+sub getTopFuncRef
+{
+ my $class = shift ;
+
+ return \&{ $TopFuncMap{$class} } ;
+}
+
+sub getTopFuncName
+{
+ my $class = shift ;
+
+ return $TopFuncMap{$class} ;
+}
+
+sub compressBuffer
+{
+ my $compWith = shift ;
+ my $buffer = shift ;
+
+ my %mapping = ( 'IO::Uncompress::Gunzip' => 'IO::Compress::Gzip',
+ 'IO::Uncompress::Gunzip::gunzip' => 'IO::Compress::Gzip',
+ 'IO::Uncompress::Inflate' => 'IO::Compress::Deflate',
+ 'IO::Uncompress::Inflate::inflate' => 'IO::Compress::Deflate',
+ 'IO::Uncompress::RawInflate' => 'IO::Compress::RawDeflate',
+ 'IO::Uncompress::RawInflate::rawinflate' => 'IO::Compress::RawDeflate',
+ 'IO::Uncompress::AnyInflate' => 'IO::Compress::Gzip',
+ 'IO::Uncompress::AnyInflate::anyinflate' => 'IO::Compress::Gzip',
+ );
+
+ my $out ;
+ my $obj = $mapping{$compWith}->new( \$out);
+ $obj->write($buffer) ;
+ $obj->close();
+ return $out ;
+
+}
+
+use IO::Uncompress::AnyInflate qw($AnyInflateError);
+sub anyUncompress
+{
+ my $buffer = shift ;
+ my $already = shift;
+
+ my @opts = ();
+ if (ref $buffer && ref $buffer eq 'ARRAY')
+ {
+ @opts = @$buffer;
+ $buffer = shift @opts;
+ }
+
+ if (ref $buffer)
+ {
+ croak "buffer is undef" unless defined $$buffer;
+ croak "buffer is empty" unless length $$buffer;
+
+ }
+
+
+ my $data ;
+ if (Compress::Zlib::Common::isaFilehandle($buffer))
+ {
+ $data = readFile($buffer);
+ }
+ elsif (Compress::Zlib::Common::isaFilename($buffer))
+ {
+ $data = readFile($buffer);
+ }
+ else
+ {
+ $data = $$buffer ;
+ }
+
+ if (defined $already && length $already)
+ {
+
+ my $got = substr($data, 0, length($already));
+ substr($data, 0, length($already)) = '';
+
+ is $got, $already, ' Already OK' ;
+ }
+
+ my $out = '';
+ my $o = new IO::Uncompress::AnyInflate \$data, -Append => 1, Transparent => 0, @opts
+ or croak "Cannot open buffer/file: $AnyInflateError" ;
+
+ 1 while $o->read($out) > 0 ;
+
+ croak "Error uncompressing -- " . $o->error()
+ if $o->error() ;
+
+ return $out ;
+
+}
+
+sub mkErr
+{
+ my $string = shift ;
+ my ($dummy, $file, $line) = caller ;
+ -- $line ;
+
+ $file = quotemeta($file);
+
+ return "/$string\\s+at $file line $line/" ;
+}
+
+sub mkEvalErr
+{
+ my $string = shift ;
+
+ return "/$string\\s+at \\(eval /" ;
+}
+
+sub dumpObj
+{
+ my $obj = shift ;
+
+ my ($dummy, $file, $line) = caller ;
+
+ if (@_)
+ {
+ print "#\n# dumpOBJ from $file line $line @_\n" ;
+ }
+ else
+ {
+ print "#\n# dumpOBJ from $file line $line \n" ;
+ }
+
+ my $max = 0 ;;
+ foreach my $k (keys %{ *$obj })
+ {
+ $max = length $k if length $k > $max ;
+ }
+
+ foreach my $k (sort keys %{ *$obj })
+ {
+ my $v = $obj->{$k} ;
+ $v = '-undef-' unless defined $v;
+ my $pad = ' ' x ($max - length($k) + 2) ;
+ print "# $k$pad: [$v]\n";
+ }
+ print "#\n" ;
+}
+
+
+package ZlibTestUtils;
+
+1;
https://perl5.git.perl.org / perl5.git / commitdiff