ext/Compress/Zlib/fallback/constants.h Compress::Zlib
ext/Compress/Zlib/fallback/constants.xs Compress::Zlib
ext/Compress/Zlib/lib/Compress/Gzip/Constants.pm Compress::Zlib
+ext/Compress/Zlib/lib/CompressPlugin/Deflate.pm Compress::Zlib
+ext/Compress/Zlib/lib/CompressPlugin/Identity.pm Compress::Zlib
+ext/Compress/Zlib/lib/Compress/Zip/Constants.pm Compress::Zlib
ext/Compress/Zlib/lib/Compress/Zlib/Common.pm Compress::Zlib
ext/Compress/Zlib/lib/Compress/Zlib/FileConstants.pm Compress::Zlib
ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm Compress::Zlib
ext/Compress/Zlib/lib/File/GlobMapper.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Compress/Base.pm Compress::Zlib
ext/Compress/Zlib/lib/IO/Compress/Deflate.pm Compress::Zlib
ext/Compress/Zlib/lib/IO/Compress/Gzip.pm Compress::Zlib
ext/Compress/Zlib/lib/IO/Compress/RawDeflate.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Compress/Zip.pm Compress::Zlib
ext/Compress/Zlib/lib/IO/Uncompress/AnyInflate.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Uncompress/AnyUncompress.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Uncompress/Base.pm Compress::Zlib
ext/Compress/Zlib/lib/IO/Uncompress/Gunzip.pm Compress::Zlib
ext/Compress/Zlib/lib/IO/Uncompress/Inflate.pm Compress::Zlib
ext/Compress/Zlib/lib/IO/Uncompress/RawInflate.pm Compress::Zlib
+ext/Compress/Zlib/lib/IO/Uncompress/Unzip.pm Compress::Zlib
+ext/Compress/Zlib/lib/UncompressPlugin/Identity.pm Compress::Zlib
+ext/Compress/Zlib/lib/UncompressPlugin/Inflate.pm Compress::Zlib
ext/Compress/Zlib/Makefile.PL Compress::Zlib
ext/Compress/Zlib/pod/FAQ.pod Compress::Zlib
ext/Compress/Zlib/ppport.h Compress::Zlib
ext/Compress/Zlib/t/01version.t Compress::Zlib
ext/Compress/Zlib/t/02zlib.t Compress::Zlib
ext/Compress/Zlib/t/03zlib-v1.t Compress::Zlib
-ext/Compress/Zlib/t/04def.t Compress::Zlib
+ext/Compress/Zlib/t/04generic-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/04generic-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/04generic-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/04generic-zip.t Compress::Zlib
+ext/Compress/Zlib/t/04zlib-generic-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/04zlib-generic-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/04zlib-generic-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/04zlib-generic-zip.t Compress::Zlib
ext/Compress/Zlib/t/05examples.t Compress::Zlib
ext/Compress/Zlib/t/06gzsetp.t Compress::Zlib
ext/Compress/Zlib/t/07bufsize.t Compress::Zlib
ext/Compress/Zlib/t/09gziphdr.t Compress::Zlib
ext/Compress/Zlib/t/10defhdr.t Compress::Zlib
ext/Compress/Zlib/t/11truncate.t Compress::Zlib
-ext/Compress/Zlib/t/12any.t Compress::Zlib
-ext/Compress/Zlib/t/13prime.t Compress::Zlib
+ext/Compress/Zlib/t/12any-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/12any-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/12any-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/12any-transparent.t Compress::Zlib
+ext/Compress/Zlib/t/12any-zip.t Compress::Zlib
+ext/Compress/Zlib/t/13prime-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/13prime-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/13prime-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/13prime-zip.t Compress::Zlib
ext/Compress/Zlib/t/14gzopen.t Compress::Zlib
-ext/Compress/Zlib/t/15multi.t Compress::Zlib
-ext/Compress/Zlib/t/16oneshot.t Compress::Zlib
+ext/Compress/Zlib/t/15multi-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/15multi-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/15multi-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/15multi-zip.t Compress::Zlib
+ext/Compress/Zlib/t/16oneshot-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/16oneshot-gzip-only.t Compress::Zlib
+ext/Compress/Zlib/t/16oneshot-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/16oneshot-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/16oneshot-zip-only.t Compress::Zlib
+ext/Compress/Zlib/t/16oneshot-zip.t Compress::Zlib
ext/Compress/Zlib/t/17isize.t Compress::Zlib
ext/Compress/Zlib/t/18lvalue.t Compress::Zlib
-ext/Compress/Zlib/t/19destroy.t Compress::Zlib
-ext/Compress/Zlib/t/20tied.t Compress::Zlib
-ext/Compress/Zlib/t/21newtied.t Compress::Zlib
-ext/Compress/Zlib/t/22merge.t Compress::Zlib
+ext/Compress/Zlib/t/19destroy-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/19destroy-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/19destroy-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/19destroy-zip.t Compress::Zlib
+ext/Compress/Zlib/t/20tied-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/20tied-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/20tied-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/20tied-zip.t Compress::Zlib
+ext/Compress/Zlib/t/21newtied-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/21newtied-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/21newtied-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/21newtied-zip.t Compress::Zlib
+ext/Compress/Zlib/t/22merge-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/22merge-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/22merge-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/22merge-zip.t Compress::Zlib
ext/Compress/Zlib/t/23misc.t Compress::Zlib
+ext/Compress/Zlib/t/25anyunc-deflate.t Compress::Zlib
+ext/Compress/Zlib/t/25anyunc-gzip.t Compress::Zlib
+ext/Compress/Zlib/t/25anyunc-rawdeflate.t Compress::Zlib
+ext/Compress/Zlib/t/25anyunc-transparent.t Compress::Zlib
+ext/Compress/Zlib/t/25anyunc-zip.t Compress::Zlib
+ext/Compress/Zlib/t/99pod.t Compress::Zlib
ext/Compress/Zlib/t/globmapper.t Compress::Zlib
ext/Compress/Zlib/typemap Compress::Zlib
ext/Compress/Zlib/Zlib.pm Compress::Zlib
t/lib/common.pl Helper for lib/{warnings,feature}.t
t/lib/commonsense.t See if configuration meets basic needs
t/lib/compmod.pl Helper for 1_compile.t
+t/lib/compress/ZlibTestUtils.pm Compress::Zlib
+t/lib/compress/any.pl Compress::Zlib
+t/lib/compress/anyunc.pl Compress::Zlib
+t/lib/compress/destroy.pl Compress::Zlib
+t/lib/compress/generic.pl Compress::Zlib
+t/lib/compress/merge.pl Compress::Zlib
+t/lib/compress/multi.pl Compress::Zlib
+t/lib/compress/newtied.pl Compress::Zlib
+t/lib/compress/oneshot.pl Compress::Zlib
+t/lib/compress/prime.pl Compress::Zlib
+t/lib/compress/tied.pl Compress::Zlib
+t/lib/compress/truncate.pl Compress::Zlib
+t/lib/compress/zlib-generic.pl Compress::Zlib
t/lib/contains_pod.xr Pod-Parser test file
t/lib/cygwin.t Builtin cygwin function tests
t/lib/Devel/switchd.pm Module for t/run/switchd.t
t/lib/warnings/universal Tests for universal.c for warnings.t
t/lib/warnings/utf8 Tests for utf8.c for warnings.t
t/lib/warnings/util Tests for util.c for warnings.t
-t/lib/ZlibTestUtils.pm Compress::Zlib
Todo.micro The Wishlist for microperl
toke.c The tokener
t/op/64bitint.t See if 64 bit integers work
CHANGES
-------
+ 2.000_07 9 January 2006
+
+ * Breakout zlib specific code into separate modules.
+
+ * Limited support for reading/writing zip files
+
+ 2.000_06 5 October 2005
+
+ * Added eof parameter to Compress::Zlib::inflate method.
+
+ * Fixed issue with 64-bit
+
2.000_05 4 October 2005
* Renamed IO::* to IO::Compress::* & IO::Uncompress::*
my $GZIP_OS_CODE = -1 ;
#$WALL = ' -pedantic ' if $Config{'cc'} =~ /gcc/ ;
-$WALL = ' -Wall -Wno-comment ' if $Config{'cc'} =~ /gcc/ ;
+#$WALL = ' -Wall -Wno-comment ' if $Config{'cc'} =~ /gcc/ ;
+
+unless($ENV{PERL_CORE}) {
+ $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV;
+}
-my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV;
# don't ask if MM_USE_DEFAULT is set -- enables perl core building on cygwin
-if ($^O =~ /cygwin/i and not ($ENV{PERL_MM_USE_DEFAULT} || $PERL_CORE))
+if ($^O =~ /cygwin/i and not ($ENV{PERL_MM_USE_DEFAULT} or $ENV{PERL_CORE}))
{
print <<EOM ;
my @files = ('Zlib.pm', 't/ZlibTestUtils.pm',
glob("t/*.t"),
+ glob("t/*.pl"),
+ glob("lib/CompressPlugin/*.pm"),
+ glob("lib/UncompressPlugin/*.pm"),
glob("lib/IO/Compress/*.pm"),
glob("lib/IO/Uncompress/*.pm"),
glob("lib/Compress/Zlib/*.pm"),
glob("lib/Compress/Gzip/*.pm"),
glob("lib/File/*.pm"),
+ glob("bzip2/*.pm"),
grep(!/\.bak$/, glob("examples/*"))) ;
-UpDowngrade(@files) unless $PERL_CORE;
+UpDowngrade(@files) unless $ENV{PERL_CORE};
WriteMakefile(
NAME => 'Compress::Zlib',
- VERSION_FROM => 'Zlib.pm',
+ VERSION_FROM => 'Zlib.pm',
+ #OPTIMIZE => '-g',
INC => "-I$ZLIB_INCLUDE" ,
DEFINE => "$OLD_ZLIB $WALL -DGZIP_OS_CODE=$GZIP_OS_CODE" ,
- XS => { 'Zlib.xs' => 'Zlib.c' },
- $PERL_CORE
+ XS => { 'Zlib.xs' => 'Zlib.c'},
+ $ENV{PERL_CORE}
? (MAN3PODS => {})
: (PREREQ_PM => { 'Scalar::Util' => 0,
$] >= 5.005 && $] < 5.006 ? ('File::BSDGlob' => 0) : () }
- ),
+ ),
'depend' => { 'Makefile' => 'config.in' },
'clean' => { FILES => '*.c constants.h constants.xs' },
'dist' => { COMPRESS => 'gzip',
? zlib_files($ZLIB_LIB)
: (LIBS => [ "-L$ZLIB_LIB -lz " ])
),
- ($] >= 5.005
+ $] >= 5.005
? (ABSTRACT_FROM => 'Zlib.pm',
AUTHOR => 'Paul Marquess <pmqs@cpan.org>')
- : ()
- ),
+ : (),
+
) ;
my @names = qw(
NAMES => \@names,
C_FILE => 'constants.h',
XS_FILE => 'constants.xs',
+
);
}
else {
return undef
if $path =~ /(~|\.bak|_bak)$/ ||
- $path =~ /\..*\.swp$/ ||
+ $path =~ /\..*\.sw(o|p)$/ ||
$path =~ /\B\.svn\b/;
return $path;
@echo Running test suite with Devel::Cover
HARNESS_PERL_SWITCHES=-MDevel::Cover $(MAKE) test COMPRESS_ZLIB_RUN_ALL=1
-test-utf8:
- @echo Running test suite with utf-8 enabled
- env LC_ALL=en_GB.UTF-8 $(MAKE) test
-
-test-utf8de:
- @echo Running test suite with utf-8 and non-english enabled
- env LC_ALL=de_DE.UTF-8 $(MAKE) test
+test-unicode:
+ @echo Running test suite with unicode support enabled
+ env PERL_UNICODE=63 $(MAKE) test
EOM
gcov:
@echo Running test suite with gcov and Devel::Cover [needs gcc 3.4?]
- #@test "${CC}" = "gcc" || (echo 'gcov' needs gcc, you have ${CC} ; exit 1)
rm -f *.o *.gcov *.da *.bbg *.bb *.gcno
- $(MAKE) OPTIMIZE=-g DEFINE="-fprofile-arcs -ftest-coverage"
- HARNESS_PERL_SWITCHES=-MDevel::Cover $(MAKE) test
- #gcov Zlib.xs
- #gcov2perl -db cover_db Zlib.xs.gcov
-
+ HARNESS_PERL_SWITCHES=-MDevel::Cover $(MAKE) test \
+ OPTIMIZE=-g \
+ CCFLAGS=-O0\ -fprofile-arcs\ -ftest-coverage \
+ OTHERLDFLAGS=-fprofile-arcs\ -ftest-coverage
+ gcov Zlib.xs
+ gcov2perl -db cover_db Zlib.xs.gcov
EOM
return $postamble;
Compress::Zlib
- Version 2.000_05
+ Version 2.000_07
- 4 Oct 2005
+ 9 Jan 2006
- Copyright (c) 1995-2005 Paul Marquess. All rights reserved.
+ Copyright (c) 1995-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
-----------
This module provides a Perl interface to most of the zlib compression
-library. For more details see the pod documentation embedded in the
-file Zlib.pm.
+library. For more details see the pod documentation embedded in the file
+Zlib.pm.
If you have downloaded this module in the expectation of manipulating the
contents of .zip files, you will need to fetch and build the Archive::Zip
--------
For option 2, fetch a copy of the zlib source distribution from
- http://www.zlib.org and unpack it into the Compress::Zlib source
- directory. Assuming you have fetched zlib 1.2.3, it will create a
+ http://www.zlib.org and unpack it into the Compress::Zlib source directory.
+ Assuming you have fetched zlib 1.2.3, it will create a
directory called zlib-1.2.3.
Now set the variables in the file config.in as follows (if the version
- you have fetched isn't 1.2.3, change the INCLUDE and LIB variables
- appropriately):
+ you have fetched isn't 1.2.3, change the INCLUDE and LIB
+ variables appropriately):
BUILD_ZLIB = True
INCLUDE = ./zlib-1.2.3
Setting the Gzip OS Code
------------------------
-Every gzip stream stores a byte in its header to identify the Operating System
-that was used to create the gzip stream. When you build Compress::Zlib it will
-attempt to determine the value that is correct for your Operating System. This
-will then be used by IO::Gzip as the default value for the OS byte in all gzip
-headers it creates.
+Every gzip stream stores a byte in its header to identify the Operating
+System that was used to create the gzip stream. When you build
+Compress::Zlib it will attempt to determine the value that is correct for
+your Operating System. This will then be used by IO::Gzip as the default
+value for the OS byte in all gzip headers it creates.
-The variable GZIP_OS_CODE in the config.in file controls the setting of this
-value when building Compress::Zlib. If GZIP_OS_CODE is set to AUTO_DETECT,
-Compress::Zlib will attempt to determine the correct value for your Operating
-System.
+The variable GZIP_OS_CODE in the config.in file controls the setting of
+this value when building Compress::Zlib. If GZIP_OS_CODE is set to
+AUTO_DETECT, Compress::Zlib will attempt to determine the correct value for
+your Operating System.
Alternatively, you can override auto-detection of the default OS code and
-explicitly set it yourself. Set the GZIP_OS_CODE variable in the config.in file
-to be a number between 0 and 255. For example
+explicitly set it yourself. Set the GZIP_OS_CODE variable in the config.in
+file to be a number between 0 and 255. For example
GZIP_OS_CODE = 3
See RFC 1952 for valid OS codes that can be used.
-If you are running one of the less popular Operating Systems, it could be that
-the default value picked by this module is incorrect or the default value (3)
-is used when there is a better value available. When Compress::Zlib cannot
-determine what operating system you are running, it will use the default value
-3 for the OS code.
+If you are running one of the less popular Operating Systems, it could be
+that the default value picked by this module is incorrect or the default
+value (3) is used when there is a better value available. When
+Compress::Zlib cannot determine what operating system you are running, it
+will use the default value 3 for the OS code.
If you find you have to change this value, because you think the value auto
-detected is incorrect, please take a few moments to contact the author of this
-module.
+detected is incorrect, please take a few moments to contact the author of
+this module.
TROUBLESHOOTING
Be warned though -- this test suite can take hours to run on a slow box.
Also, due to the way the tests are constructed, some architectures will
-run out of memory during these test. This should not be considered a bug
+run out of memory during this test. This should not be considered a bug
in the Compress::Zlib module.
use IO::Handle ;
use Scalar::Util qw(dualvar);
-use Compress::Zlib::Common;
+use Compress::Zlib::Common ;
use Compress::Zlib::ParseParameters;
use strict ;
use bytes ;
our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD);
-$VERSION = '2.000_06';
+$VERSION = '2.000_07';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
Z_VERSION_ERROR
);
+
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
if ($writing) {
$gz = new IO::Compress::Gzip($file, Minimal => 1, AutoClose => 1,
- %defOpts)
+ %defOpts)
or $Compress::Zlib::gzerrno = $IO::Compress::Gzip::GzipError;
}
else {
$gz = new IO::Uncompress::Gunzip($file,
- Transparent => 1,
- Append => 0,
- AutoClose => 1, Strict => 0)
+ Transparent => 1,
+ Append => 0,
+ AutoClose => 1,
+ Strict => 0)
or $Compress::Zlib::gzerrno = $IO::Uncompress::Gunzip::GunzipError;
}
return _set_gzerr(Z_STREAM_ERROR())
if $self->[1] ne 'deflate';
- my $status = *$gz->{Deflate}->deflateParams(-Level => $level,
+ my $status = *$gz->{Compress}->deflateParams(-Level => $level,
-Strategy => $strategy);
_save_gzerr($gz);
return $status ;
my $pkg = shift ;
my ($got) = ParseParameters(0,
{
- 'AppendOutput' => [Parse_boolean, 0],
- 'CRC32' => [Parse_boolean, 0],
- 'ADLER32' => [Parse_boolean, 0],
- 'Bufsize' => [Parse_unsigned, 4096],
+ 'AppendOutput' => [1, 1, Parse_boolean, 0],
+ 'CRC32' => [1, 1, Parse_boolean, 0],
+ 'ADLER32' => [1, 1, Parse_boolean, 0],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
- 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION()],
- 'Method' => [Parse_unsigned, Z_DEFLATED()],
- 'WindowBits' => [Parse_signed, MAX_WBITS()],
- 'MemLevel' => [Parse_unsigned, MAX_MEM_LEVEL()],
- 'Strategy' => [Parse_unsigned, Z_DEFAULT_STRATEGY()],
- 'Dictionary' => [Parse_any, ""],
+ 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()],
+ 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()],
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()],
+ 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
}, @_) ;
my $pkg = shift ;
my ($got) = ParseParameters(0,
{
- 'AppendOutput' => [Parse_boolean, 0],
- 'CRC32' => [Parse_boolean, 0],
- 'ADLER32' => [Parse_boolean, 0],
- 'ConsumeInput' => [Parse_boolean, 1],
- 'Bufsize' => [Parse_unsigned, 4096],
+ 'AppendOutput' => [1, 1, Parse_boolean, 0],
+ 'CRC32' => [1, 1, Parse_boolean, 0],
+ 'ADLER32' => [1, 1, Parse_boolean, 0],
+ 'ConsumeInput' => [1, 1, Parse_boolean, 1],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
- 'WindowBits' => [Parse_signed, MAX_WBITS()],
- 'Dictionary' => [Parse_any, ""],
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
}, @_) ;
my $pkg = shift ;
my ($got) = ParseParameters(0,
{
- 'CRC32' => [Parse_boolean, 0],
- 'ADLER32' => [Parse_boolean, 0],
- 'Bufsize' => [Parse_unsigned, 4096],
+ 'CRC32' => [1, 1, Parse_boolean, 0],
+ 'ADLER32' => [1, 1, Parse_boolean, 0],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
- 'WindowBits' => [Parse_signed, -MAX_WBITS()],
- 'Dictionary' => [Parse_any, ""],
+ 'WindowBits' => [1, 1, Parse_signed, -MAX_WBITS()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
}, @_) ;
my $pkg = shift ;
my ($got) = ParseParameters(0,
{
- 'AppendOutput' => [Parse_boolean, 0],
- 'CRC32' => [Parse_boolean, 0],
- 'ADLER32' => [Parse_boolean, 0],
- 'Bufsize' => [Parse_unsigned, 4096],
+ 'AppendOutput' => [1, 1, Parse_boolean, 0],
+ 'CRC32' => [1, 1, Parse_boolean, 0],
+ 'ADLER32' => [1, 1, Parse_boolean, 0],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
- 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION()],
- 'Method' => [Parse_unsigned, Z_DEFLATED()],
- 'WindowBits' => [Parse_signed, - MAX_WBITS()],
- 'MemLevel' => [Parse_unsigned, MAX_MEM_LEVEL()],
- 'Strategy' => [Parse_unsigned, Z_DEFAULT_STRATEGY()],
+ 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()],
+ 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()],
+ 'WindowBits' => [1, 1, Parse_signed, - MAX_WBITS()],
+ 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()],
+ 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()],
}, @_) ;
croak "Compress::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified " .
}
+sub Compress::Zlib::inflateScanStream::inflate
+{
+ my $self = shift ;
+ my $buffer = $_[1];
+ my $eof = $_[2];
+
+ my $status = $self->scan(@_);
+
+ if ($status == Z_OK() && $_[2]) {
+ my $byte = ' ';
+
+ $status = $self->scan(\$byte, $_[1]) ;
+ }
+
+ return $status ;
+}
sub Compress::Zlib::deflateStream::deflateParams
{
my $self = shift ;
my ($got) = ParseParameters(0, {
- 'Level' => [Parse_signed, undef],
- 'Strategy' => [Parse_unsigned, undef],
- 'Bufsize' => [Parse_unsigned, undef],
+ 'Level' => [1, 1, Parse_signed, undef],
+ 'Strategy' => [1, 1, Parse_unsigned, undef],
+ 'Bufsize' => [1, 1, Parse_unsigned, undef],
},
@_) ;
{
my ($got) = ParseParameters(0,
{
- 'Bufsize' => [Parse_unsigned, 4096],
- 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION()],
- 'Method' => [Parse_unsigned, Z_DEFLATED()],
- 'WindowBits' => [Parse_signed, MAX_WBITS()],
- 'MemLevel' => [Parse_unsigned, MAX_MEM_LEVEL()],
- 'Strategy' => [Parse_unsigned, Z_DEFAULT_STRATEGY()],
- 'Dictionary' => [Parse_any, ""],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+ 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()],
+ 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()],
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()],
+ 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
}, @_ ) ;
croak "Compress::Zlib::deflateInit: Bufsize must be >= 1, you specified " .
$got->value('Bufsize')
unless $got->value('Bufsize') >= 1;
- my (%obj) = () ;
+ my $obj ;
my $status = 0 ;
- ($obj{def}, $status) =
+ ($obj, $status) =
_deflateInit(0,
$got->value('Level'),
$got->value('Method'),
$got->value('Bufsize'),
$got->value('Dictionary')) ;
- my $x = ($status == Z_OK() ? bless \%obj, "Zlib::OldDeflate" : undef) ;
+ my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldDeflate" : undef) ;
return wantarray ? ($x, $status) : $x ;
}
{
my ($got) = ParseParameters(0,
{
- 'Bufsize' => [Parse_unsigned, 4096],
- 'WindowBits' => [Parse_signed, MAX_WBITS()],
- 'Dictionary' => [Parse_any, ""],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
}, @_) ;
unless $got->value('Bufsize') >= 1;
my $status = 0 ;
- my (%obj) = () ;
- ($obj{def}, $status) = _inflateInit(FLAG_CONSUME_INPUT,
+ my $obj ;
+ ($obj, $status) = _inflateInit(FLAG_CONSUME_INPUT,
$got->value('WindowBits'),
$got->value('Bufsize'),
$got->value('Dictionary')) ;
- my $x = ($status == Z_OK() ? bless \%obj, "Zlib::OldInflate" : undef) ;
+ my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldInflate" : undef) ;
wantarray ? ($x, $status) : $x ;
}
package Zlib::OldDeflate ;
+our (@ISA);
+@ISA = qw(Compress::Zlib::deflateStream);
+
+
sub deflate
{
my $self = shift ;
my $output ;
- #my (@rest) = @_ ;
-
- my $status = $self->{def}->deflate($_[0], $output) ;
+ my $status = $self->SUPER::deflate($_[0], $output) ;
wantarray ? ($output, $status) : $output ;
}
my $self = shift ;
my $output ;
my $flag = shift || Compress::Zlib::Z_FINISH();
- my $status = $self->{def}->flush($output, $flag) ;
+ my $status = $self->SUPER::flush($output, $flag) ;
wantarray ? ($output, $status) : $output ;
}
-sub deflateParams
-{
- my $self = shift ;
- $self->{def}->deflateParams(@_) ;
-}
-
-sub msg
-{
- my $self = shift ;
- $self->{def}->msg() ;
-}
-
-sub total_in
-{
- my $self = shift ;
- $self->{def}->total_in() ;
-}
-
-sub total_out
-{
- my $self = shift ;
- $self->{def}->total_out() ;
-}
-
-sub dict_adler
-{
- my $self = shift ;
- $self->{def}->dict_adler() ;
-}
-
-sub get_Level
-{
- my $self = shift ;
- $self->{def}->get_Level() ;
-}
-
-sub get_Strategy
-{
- my $self = shift ;
- $self->{def}->get_Strategy() ;
-}
-
-#sub DispStream
-#{
-# my $self = shift ;
-# $self->{def}->DispStream($_[0]) ;
-#}
-
package Zlib::OldInflate ;
+our (@ISA);
+@ISA = qw(Compress::Zlib::inflateStream);
+
sub inflate
{
my $self = shift ;
my $output ;
- my $status = $self->{def}->inflate($_[0], $output) ;
+ my $status = $self->SUPER::inflate($_[0], $output) ;
wantarray ? ($output, $status) : $output ;
}
-sub inflateSync
-{
- my $self = shift ;
- $self->{def}->inflateSync($_[0]) ;
-}
-
-sub msg
-{
- my $self = shift ;
- $self->{def}->msg() ;
-}
-
-sub total_in
-{
- my $self = shift ;
- $self->{def}->total_in() ;
-}
-
-sub total_out
-{
- my $self = shift ;
- $self->{def}->total_out() ;
-}
-
-sub dict_adler
-{
- my $self = shift ;
- $self->{def}->dict_adler() ;
-}
-
-#sub DispStream
-#{
-# my $self = shift ;
-# $self->{def}->DispStream($_[0]) ;
-#}
-
package Compress::Zlib ;
use Compress::Gzip::Constants;
$d->get_BufSize();
($i, $status) = new Compress::Zlib::Inflate( [OPT] ) ;
- $status = $i->inflate($input, $output) ;
+ $status = $i->inflate($input, $output [, $eof]) ;
$status = $i->inflateSync($input) ;
$i->dict_adler() ;
$d->crc32() ;
=item 1
-If you want to to open either STDIN or STDOUT with C<gzopen>, you can
+If you want to to open either STDIN or STDOUT with C<gzopen>, you can now
optionally use the special filename "C<->" as a synonym for C<\*STDIN> and
C<\*STDOUT>.
and closing the file multiple times.
In C<Compress::Zlib> version 2.x, the C<gzopen> interface has been completely
-rewritten to use the L<IO::Compress::Gzip|IO::Compress::Gzip> for writing gzip files and
-L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for reading gzip files.
+rewritten to use the L<IO::Gzip|IO::Gzip> for writing gzip files and
+L<IO::Gunzip|IO::Gunzip> for reading gzip files.
=item 3
=back
-A more complete and flexible interface for reading/writing gzip files/buffers
-is included with this module. See L<IO::Compress::Gzip|IO::Compress::Gzip> and
-L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for more details.
+A more complete and flexible interface for reading/writing gzip
+files/buffers is included with this module. See L<IO::Gzip|IO::Gzip> and
+L<IO::Gunzip|IO::Gunzip> for more details.
=over 5
=item B<$gz = gzopen($filehandle, $mode)>
-This function opens either the I<gzip> file C<$filename> for reading or writing
-or attaches to the opened filehandle, C<$filehandle>. It returns an object on
-success and C<undef> on failure.
+This function opens either the I<gzip> file C<$filename> for reading or
+writing or attaches to the opened filehandle, C<$filehandle>.
+It returns an object on success and C<undef> on failure.
When writing a gzip file this interface will always create the smallest
-possible gzip header (exactly 10 bytes). If you want control over the
-information stored in the gzip header (like the original filename or a comment)
-use L<IO::Compress::Gzip|IO::Compress::Gzip> instead.
+possible gzip header (exactly 10 bytes). If you want greater control over
+the information stored in the gzip header (like the original filename or a
+comment) use L<IO::Gzip|IO::Gzip> instead.
The second parameter, C<$mode>, is used to specify whether the file is
opened for reading or writing and to optionally specify a compression
=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.
The C<$buffer> parameter can either be a scalar or a scalar reference.
-See L<IO::Compress::Gzip|IO::Compress::Gzip> for an alternative way to carry out in-memory gzip
+See L<IO::Gzip|IO::Gzip> for an alternative way to carry out in-memory gzip
compression.
=head2 Compress::Zlib::memGunzip
The C<$buffer> parameter can either be a scalar or a scalar reference. The
contents of the C<$buffer> parameter are destroyed after calling this function.
-See L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for an alternative way to carry out in-memory gzip
+See L<IO::Gunzip|IO::Gunzip> for an alternative way to carry out in-memory gzip
uncompression.
=head1 COMPRESS/UNCOMPRESS
Please note: the two functions defined above are I<not> compatible with
the Unix commands of the same name.
-See L<IO::Compress::Deflate|IO::Compress::Deflate> and L<IO::Uncompress::Inflate|IO::Uncompress::Inflate> included with
+See L<IO::Deflate|IO::Deflate> and L<IO::Inflate|IO::Inflate> included with
this distribution for an alternative interface for reading/writing RFC 1950
files/buffers.
=item B<-WindowBits>
-For a definition of the meaning and valid values for C<WindowBits>
-refer to the I<zlib> documentation for I<inflateInit2>.
+To uncompress an RFC1950 data stream, set C<WindowBits> to a positive number.
+
+To uncompress an RFC1951 data stream, set C<WindowBits> to C<-MAX_WBITS>.
+
+For a full definition of the meaning and valid values for C<WindowBits> refer
+to the I<zlib> documentation for I<inflateInit2>.
Defaults to C<-WindowBits =E<gt>MAX_WBITS>.
my ($i, $status) = new Compress::Zlib::Inflate( -Bufsize => 300 ) ;
-=head2 B< $status = $i-E<gt>inflate($input, $output) >
+=head2 B< $status = $i-E<gt>inflate($input, $output [,$eof]) >
Inflates the complete contents of C<$input> and writes the uncompressed
data to C<$output>. The C<$input> and C<$output> parameters can either be
it is false, C<$output> will be truncated before any uncompressed data
is written to it.
+The C<$eof> parameter needs a bit of explanation.
+
+Prior to version 1.2.0, zlib assumed that there was at least one trailing
+byte immediately after the compressed data stream when it was carrying out
+decompression. This normally isn't a problem because the majority of zlib
+applications guarantee that there will be data directly after the
+compressed data stream. For example, both gzip (RFC1950) and zip both
+define trailing data that follows the compressed data stream.
+
+The C<$eof> parameter only needs to be used if B<all> of the following
+conditions apply
+
+=over 5
+
+=item 1
+
+You are either using a copy of zlib that is older than version 1.2.0 or you
+want your application code to be able to run with as many different
+versions of zlib as possible.
+
+=item 2
+
+You have set the C<WindowBits> parameter to C<-MAX_WBITS> in the constructor
+for this object, i.e. you are uncompressing a raw deflated data stream
+(RFC1951).
+
+=item 3
+
+There is no data immediately after the compressed data stream.
+
+=back
+
+If B<all> of these are the case, then you need to set the C<$eof> parameter to
+true on the final call (and only the final call) to C<$i-E<gt>inflate>.
+
+If you have built this module with zlib >= 1.2.0, the C<$eof> parameter is
+ignored. You can still set it if you want, but it won't be used behind the
+scenes.
+
=head2 B<$status = $i-E<gt>inflateSync($input)>
This method can be used to attempt to recover good data from a compressed
=item B<-WindowBits>
-For a definition of the meaning and valid values for C<WindowBits>
-refer to the I<zlib> documentation for I<deflateInit2>.
+To create an RFC1950 data stream, set C<WindowBits> to a positive number.
+
+To create an RFC1951 data stream, set C<WindowBits> to C<-MAX_WBITS>.
+
+For a full definition of the meaning and valid values for C<WindowBits> refer
+to the I<zlib> documentation for I<deflateInit2>.
Defaults to C<-WindowBits =E<gt>MAX_WBITS>.
=head2 B<($i, $status) = inflateInit()>
-Initialises an inflation stream.
+Initializes an inflation stream.
In a list context it returns the inflation stream, C<$i>, and the
I<zlib> status code (C<$status>). In a scalar context it returns the
=item B<-WindowBits>
-For a definition of the meaning and valid values for C<WindowBits>
-refer to the I<zlib> documentation for I<inflateInit2>.
+To uncompress an RFC1950 data stream, set C<WindowBits> to a positive number.
+
+To uncompress an RFC1951 data stream, set C<WindowBits> to C<-MAX_WBITS>.
+
+For a full definition of the meaning and valid values for C<WindowBits> refer
+to the I<zlib> documentation for I<inflateInit2>.
Defaults to C<-WindowBits =E<gt>MAX_WBITS>.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 1995-2005 Paul Marquess. All rights reserved.
+Copyright (c) 1995-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
#include <zlib.h>
+/* zlib prior to 1.06 doesn't know about z_off_t */
+#ifndef z_off_t
+# define z_off_t long
+#endif
+
+#if ! defined(ZLIB_VERNUM) || ZLIB_VERNUM < 0x1200
+# define NEED_DUMMY_BYTE_AT_END
+#endif
#if defined(ZLIB_VERNUM) && ZLIB_VERNUM >= 0x1210
# define MAGIC_APPEND
#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 newSVuv newSViv
# endif
-#endif
-
-#if PERL_REVISION == 5 && (PERL_VERSION >= 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 4 ))
-# define UTF8_AVAILABLE
-#endif
-#if PERL_REVISION == 5 && (PERL_VERSION < 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 4 ))
+# if PERL_REVISION == 5 && (PERL_VERSION < 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 4 ))
# ifdef SvPVbyte_force
# undef SvPVbyte_force
# define SvPVbyte_force(sv,lp) SvPV_force(sv,lp)
-#endif
+# endif
-#ifndef SvPVbyte_nolen
+# ifndef SvPVbyte_nolen
# define SvPVbyte_nolen SvPV_nolen
-#endif
+# endif
-#ifndef SvPVbyte
+# ifndef SvPVbyte
# define SvPVbyte SvPV
-#endif
+# endif
-#ifndef dTHX
+# ifndef dTHX
# define dTHX
-#endif
+# endif
-#ifndef SvPV_nolen
+# ifndef SvPV_nolen
-#define sv_2pv_nolen(a) my_sv_2pv_nolen(a)
+# define sv_2pv_nolen(a) my_sv_2pv_nolen(a)
static char *
my_sv_2pv_nolen(register SV *sv)
{
+ dTHX;
STRLEN n_a;
return sv_2pv(sv, &n_a);
}
/* SvPV_nolen depends on sv_2pv_nolen */
-#define SvPV_nolen(sv) \
+# define SvPV_nolen(sv) \
((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
? SvPVX(sv) : sv_2pv_nolen(sv))
+# endif
+
+# ifndef SvGETMAGIC
+# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+# endif
+
#endif
-#ifndef SvGETMAGIC
-# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+# ifndef SvPVbyte_nolen
+# define SvPVbyte_nolen SvPV_nolen
+# endif
+
+# ifndef SvPVbyte_force
+# define SvPVbyte_force(sv,lp) SvPV_force(sv,lp)
+# endif
+
+#if PERL_REVISION == 5 && (PERL_VERSION >= 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 4 ))
+# define UTF8_AVAILABLE
#endif
typedef int DualType ;
int MemLevel;
int Strategy;
uLong bytesInflated ;
+ uLong compressedBytes ;
+ uLong uncompressedBytes ;
#ifdef MAGIC_APPEND
#define WINDOW_SIZE 32768U
int error_no ;
#endif
{
+ dTHX;
char * errstr ;
SV * gzerror_sv = perl_get_sv(GZERRNO, FALSE) ;
{
s->bufsize = bufsize ;
s->bufinc = bufsize ;
+ s->compressedBytes =
+ s->uncompressedBytes =
s->last_error = 0 ;
s->flags = flags ;
s->zip_mode = (windowBits < 0) ;
SvIOK_on(gzerror_sv) ;
}
-
-int
-_readonly_ref(sv)
- SV* sv
- CODE:
- if (SvROK(sv))
- RETVAL = SvREADONLY(SvRV(sv)) ;
- else
- RETVAL = SvREADONLY(sv) ;
- OUTPUT:
- RETVAL
-
-void
-_dualvar(num,str)
- SV * num
- SV * str
-PROTOTYPE: $$
-CODE:
-{
- STRLEN len;
- char *ptr = SvPVbyte(str,len);
- ST(0) = sv_newmortal();
- SvUPGRADE(ST(0),SVt_PVNV);
- sv_setpvn(ST(0),ptr,len);
- if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
- SvNV_set(ST(0), SvNV(num));
- SvNOK_on(ST(0));
- }
-#ifdef SVf_IVisUVXXXX
- else if (SvUOK(num)) {
- SvUVX(ST(0)) = SvUV(num);
- SvIOK_on(ST(0));
- SvIsUV_on(ST(0));
- }
-#endif
- else {
- SvIV_set(ST(0), SvIV(num));
- SvIOK_on(ST(0));
- }
- XSRETURN(1);
-}
-
-
#define Zip_zlib_version() (char*)zlib_version
char*
Zip_zlib_version()
SV * output
uInt cur_length = NO_INIT
uInt increment = NO_INIT
+ uInt prefix = NO_INIT
int RETVAL = 0;
CODE:
croak("Wide character in Compress::Zlib::Deflate::deflate input parameter");
#endif
s->stream.next_in = (Bytef*)SvPVbyte_nolen(buf) ;
- s->stream.avail_in = SvCUR(buf) ;
+ s->stream.avail_in = SvCUR(buf) ;
if (s->flags & FLAG_CRC32)
s->crc32 = crc32(s->crc32, s->stream.next_in, s->stream.avail_in) ;
SvCUR_set(output, 0);
/* sv_setpvn(output, "", 0); */
}
- cur_length = SvCUR(output) ;
+ prefix = cur_length = SvCUR(output) ;
s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length;
increment = SvLEN(output) - cur_length;
s->stream.avail_out = increment;
break;
}
+ s->compressedBytes += cur_length + increment - prefix - s->stream.avail_out ;
+ s->uncompressedBytes += SvCUR(buf) - s->stream.avail_in ;
+
s->last_error = RETVAL ;
if (RETVAL == Z_OK) {
SvPOK_only(output);
int f
uInt cur_length = NO_INIT
uInt increment = NO_INIT
+ uInt prefix = NO_INIT
CODE:
s->stream.avail_in = 0; /* should be zero already anyway */
SvCUR_set(output, 0);
/* sv_setpvn(output, "", 0); */
}
- cur_length = SvCUR(output) ;
+ prefix = cur_length = SvCUR(output) ;
s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length;
increment = SvLEN(output) - cur_length;
s->stream.avail_out = increment;
RETVAL = (RETVAL == Z_STREAM_END ? Z_OK : RETVAL) ;
s->last_error = RETVAL ;
+
+ s->compressedBytes += cur_length + increment - prefix - s->stream.avail_out ;
if (RETVAL == Z_OK) {
SvPOK_only(output);
RETVAL
uLong
+compressedBytes(s)
+ Compress::Zlib::deflateStream s
+ CODE:
+ RETVAL = s->compressedBytes;
+ OUTPUT:
+ RETVAL
+
+uLong
+uncompressedBytes(s)
+ Compress::Zlib::deflateStream s
+ CODE:
+ RETVAL = s->uncompressedBytes;
+ OUTPUT:
+ RETVAL
+
+uLong
total_in(s)
Compress::Zlib::deflateStream s
CODE:
RETVAL
DualType
-inflate (s, buf, output)
+inflate (s, buf, output, eof=FALSE)
Compress::Zlib::inflateStream s
SV * buf
SV * output
+ bool eof
uInt cur_length = 0;
uInt prefix_length = 0;
uInt increment = 0;
- STRLEN stmp = NO_INIT
+ STRLEN stmp = NO_INIT
PREINIT:
#ifdef UTF8_AVAILABLE
bool out_utf8 = FALSE;
/* initialise the input buffer */
s->stream.next_in = (Bytef*)SvPVbyte_force(buf, stmp) ;
- s->stream.avail_in = SvCUR(buf) ;
+ s->stream.avail_in = SvCUR(buf) ;
/* and retrieve the output buffer */
output = deRef_l(output, "inflate") ;
RETVAL = inflate(&(s->stream), Z_SYNC_FLUSH);
+ if (RETVAL == Z_STREAM_ERROR || RETVAL == Z_MEM_ERROR ||
+ RETVAL == Z_DATA_ERROR || RETVAL == Z_STREAM_END )
+ break ;
if (RETVAL == Z_BUF_ERROR) {
if (s->stream.avail_out == 0)
if (RETVAL != Z_OK)
break;
}
-
+#ifdef NEED_DUMMY_BYTE_AT_END
+ if (eof && RETVAL == Z_OK) {
+ Bytef* nextIn = s->stream.next_in;
+ uInt availIn = s->stream.avail_in;
+ s->stream.next_in = (Bytef*) " ";
+ s->stream.avail_in = 1;
+ if (s->stream.avail_out == 0) {
+ /* out of space in the output buffer so make it bigger */
+ Sv_Grow(output, SvLEN(output) + s->bufinc) ;
+ cur_length += increment ;
+ s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length ;
+ increment = s->bufinc ;
+ s->stream.avail_out = increment;
+ s->bufinc *= 2 ;
+ }
+ RETVAL = inflate(&(s->stream), Z_SYNC_FLUSH);
+ s->stream.next_in = nextIn ;
+ s->stream.avail_in = availIn ;
+ }
+#endif
+
s->last_error = RETVAL ;
if (RETVAL == Z_OK || RETVAL == Z_STREAM_END || RETVAL == Z_DATA_ERROR) {
unsigned in ;
s->bytesInflated = cur_length + increment - s->stream.avail_out - prefix_length;
+ s->uncompressedBytes += s->bytesInflated ;
+ s->compressedBytes += SvCUR(buf) - s->stream.avail_in ;
+
SvPOK_only(output);
SvCUR_set(output, prefix_length + s->bytesInflated) ;
*SvEND(output) = '\0';
OUTPUT:
RETVAL
+uLong
+compressedBytes(s)
+ Compress::Zlib::inflateStream s
+ CODE:
+ RETVAL = s->compressedBytes;
+ OUTPUT:
+ RETVAL
+
+uLong
+uncompressedBytes(s)
+ Compress::Zlib::inflateStream s
+ CODE:
+ RETVAL = s->uncompressedBytes;
+ OUTPUT:
+ RETVAL
+
DualType
inflateSync (s, buf)
Compress::Zlib::inflateScanStream s
char * message
+DualType
+inflateReset(s)
+ Compress::Zlib::inflateScanStream s
+ CODE:
+ RETVAL = inflateReset(&(s->stream)) ;
+ if (RETVAL == Z_OK) {
+ PostInitStream(s, s->flags, s->bufsize, s->WindowBits) ;
+ }
+ OUTPUT:
+ RETVAL
+
DualType
-scan(s, buf, out=NULL)
+scan(s, buf, out=NULL, eof=FALSE)
Compress::Zlib::inflateScanStream s
SV * buf
SV * out
+ bool eof
+ bool eof_mode = FALSE;
int start_len = NO_INIT
- STRLEN stmp = NO_INIT
- ALIAS:
- inflate = 1
+ STRLEN stmp = NO_INIT
CODE:
/* If the input buffer is a reference, dereference it */
- ix = ix ; /* warning suppression */
#ifndef MAGIC_APPEND
buf = buf;
croak("scan needs zlib 1.2.1 or better");
if (DO_UTF8(buf) && !sv_utf8_downgrade(buf, 1))
croak("Wide character in Compress::Zlib::InflateScan::scan input parameter");
#endif
-
/* initialise the input buffer */
s->stream.next_in = (Bytef*)SvPVbyte_force(buf, stmp) ;
- s->stream.avail_in = SvCUR(buf) ;
+ s->stream.avail_in = SvCUR(buf) ;
start_len = s->stream.avail_in ;
s->bytesInflated = 0 ;
do
/* inflate and check for errors */
RETVAL = inflate(&(s->stream), Z_BLOCK);
-
- if (start_len > 1)
+ if (start_len > 1 && ! eof_mode)
s->window_lastByte = *(s->stream.next_in - 1 ) ;
if (RETVAL == Z_STREAM_ERROR || RETVAL == Z_MEM_ERROR ||
s->adler32 = adler32(s->adler32, s->window + s->window_have,
WINDOW_SIZE - s->window_have - s->stream.avail_out);
+ s->uncompressedBytes =
s->bytesInflated += WINDOW_SIZE - s->window_have - s->stream.avail_out;
if (s->stream.avail_out)
s->last_error = RETVAL ;
s->window_lastoff = s->stream.total_in ;
+ s->compressedBytes += SvCUR(buf) - s->stream.avail_in ;
if (RETVAL == Z_STREAM_END)
{
OUTPUT:
RETVAL
+uLong
+compressedBytes(s)
+ Compress::Zlib::inflateStream s
+ CODE:
+ RETVAL = s->compressedBytes;
+ OUTPUT:
+ RETVAL
+
+uLong
+uncompressedBytes(s)
+ Compress::Zlib::inflateStream s
+ CODE:
+ RETVAL = s->uncompressedBytes;
+ OUTPUT:
+ RETVAL
+
uLong
getLastBlockOffset(s)
our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names);
our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE);
-$VERSION = '2.000_05';
+$VERSION = '2.000_07';
@ISA = qw(Exporter);
--- /dev/null
+package Compress::Zip::Constants;
+
+use strict ;
+use warnings;
+
+require Exporter;
+
+our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names);
+
+$VERSION = '1.00';
+
+@ISA = qw(Exporter);
+
+@EXPORT= qw(
+
+ ZIP_ID_SIZE
+ GZIP_ID1
+ GZIP_ID2
+
+ GZIP_FLG_DEFAULT
+ GZIP_FLG_FTEXT
+ GZIP_FLG_FHCRC
+ GZIP_FLG_FEXTRA
+ GZIP_FLG_FNAME
+ GZIP_FLG_FCOMMENT
+ GZIP_FLG_RESERVED
+
+ GZIP_CM_DEFLATED
+
+ GZIP_MIN_HEADER_SIZE
+ GZIP_TRAILER_SIZE
+
+ GZIP_MTIME_DEFAULT
+ GZIP_FEXTRA_DEFAULT
+ GZIP_FEXTRA_HEADER_SIZE
+ GZIP_FEXTRA_MAX_SIZE
+ GZIP_FEXTRA_SUBFIELD_HEADER_SIZE
+ GZIP_FEXTRA_SUBFIELD_ID_SIZE
+ GZIP_FEXTRA_SUBFIELD_LEN_SIZE
+ GZIP_FEXTRA_SUBFIELD_MAX_SIZE
+
+ GZIP_FNAME_INVALID_CHAR_RE
+ GZIP_FCOMMENT_INVALID_CHAR_RE
+
+ GZIP_FHCRC_SIZE
+
+ GZIP_ISIZE_MAX
+ GZIP_ISIZE_MOD_VALUE
+
+
+ GZIP_NULL_BYTE
+
+ GZIP_OS_DEFAULT
+
+ %GZIP_OS_Names
+
+ GZIP_MINIMUM_HEADER
+
+ );
+
+
+# Constants for the Zip Local Header
+
+use constant ZIP_ID_SIZE => 4 ;
+use constant ZIP_LOCAL_ID => 0x02014B50;
+use constant ZIP_LOCAL_ID1 => 0x04;
+use constant ZIP_LOCAL_ID2 => 0x03;
+use constant ZIP_LOCAL_ID3 => 0x4B;
+use constant ZIP_LOCAL_ID4 => 0x50;
+
+use constant ZIP_MIN_HEADER_SIZE => 30 ;
+use constant ZIP_TRAILER_SIZE => 0 ;
+
+
+use constant GZIP_FLG_DEFAULT => 0x00 ;
+use constant GZIP_FLG_FTEXT => 0x01 ;
+use constant GZIP_FLG_FHCRC => 0x02 ; # called CONTINUATION in gzip
+use constant GZIP_FLG_FEXTRA => 0x04 ;
+use constant GZIP_FLG_FNAME => 0x08 ;
+use constant GZIP_FLG_FCOMMENT => 0x10 ;
+#use constant GZIP_FLG_ENCRYPTED => 0x20 ; # documented in gzip sources
+use constant GZIP_FLG_RESERVED => (0x20 | 0x40 | 0x80) ;
+
+use constant GZIP_MTIME_DEFAULT => 0x00 ;
+use constant GZIP_FEXTRA_DEFAULT => 0x00 ;
+use constant GZIP_FEXTRA_HEADER_SIZE => 2 ;
+use constant GZIP_FEXTRA_MAX_SIZE => 0xFFFF ;
+use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => 4 ;
+use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ;
+use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ;
+use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => 0xFFFF ;
+
+use constant GZIP_FNAME_INVALID_CHAR_RE => qr/[\x00-\x1F\x7F-\x9F]/;
+use constant GZIP_FCOMMENT_INVALID_CHAR_RE => qr/[\x00-\x09\x11-\x1F\x7F-\x9F]/;
+
+use constant GZIP_FHCRC_SIZE => 2 ; # aka CONTINUATION in gzip
+
+use constant GZIP_CM_DEFLATED => 8 ;
+
+use constant GZIP_NULL_BYTE => "\x00";
+use constant GZIP_ISIZE_MAX => 0xFFFFFFFF ;
+use constant GZIP_ISIZE_MOD_VALUE => GZIP_ISIZE_MAX + 1 ;
+
+# OS Names sourced from http://www.gzip.org/format.txt
+
+use constant GZIP_OS_DEFAULT=> 0xFF ;
+%ZIP_OS_Names = (
+ 0 => 'MS-DOS',
+ 1 => 'Amiga',
+ 2 => 'VMS',
+ 3 => 'Unix',
+ 4 => 'VM/CMS',
+ 5 => 'Atari TOS',
+ 6 => 'HPFS (OS/2, NT)',
+ 7 => 'Macintosh',
+ 8 => 'Z-System',
+ 9 => 'CP/M',
+ 10 => 'TOPS-20',
+ 11 => 'NTFS (NT)',
+ 12 => 'SMS QDOS',
+ 13 => 'Acorn RISCOS',
+ 14 => 'VFAT file system (Win95, NT)',
+ 15 => 'MVS',
+ 16 => 'BeOS',
+ 17 => 'Tandem/NSK',
+ 18 => 'THEOS',
+ GZIP_OS_DEFAULT => 'Unknown',
+ ) ;
+
+use constant GZIP_MINIMUM_HEADER => pack("C4 V C C",
+ GZIP_ID1, GZIP_ID2, GZIP_CM_DEFLATED, GZIP_FLG_DEFAULT,
+ GZIP_MTIME_DEFAULT, GZIP_FEXTRA_DEFAULT, GZIP_OS_DEFAULT) ;
+
+
+1;
use File::GlobMapper;
require Exporter;
-our ($VERSION, @ISA, @EXPORT);
+our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS);
@ISA = qw(Exporter);
-$VERSION = '2.000_05';
+$VERSION = '2.000_07';
-@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput ckInputParam
+@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput
isaFileGlobString cleanFileGlobString oneTarget
setBinModeInput setBinModeOutput
- ckOutputParam ckInOutParams
+ ckInOutParams
+ createSelfTiedObject
+
WANT_CODE
WANT_EXT
WANT_UNDEF
WANT_HASH
+
+ STATUS_OK
+ STATUS_ENDSTREAM
+ STATUS_ERROR
);
+%EXPORT_TAGS = ( Status => [qw( STATUS_OK
+ STATUS_ENDSTREAM
+ STATUS_ERROR
+ )]);
+
+
+use constant STATUS_OK => 0;
+use constant STATUS_ENDSTREAM => 1;
+use constant STATUS_ERROR => 2;
+
our ($needBinmode);
$needBinmode = ($^O eq 'MSWin32' ||
($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
use constant WANT_CODE => 1 ;
use constant WANT_EXT => 2 ;
use constant WANT_UNDEF => 4 ;
-use constant WANT_HASH => 8 ;
+#use constant WANT_HASH => 8 ;
+use constant WANT_HASH => 0 ;
sub whatIsInput($;$)
{
return $_[0] =~ /^(code|handle|buffer|filename)$/;
}
-sub ckInputParam ($$$;$)
-{
- my $from = shift ;
- my $inType = whatIsInput($_[0], $_[2]);
- local $Carp::CarpLevel = 1;
-
- croak "$from: input parameter not a filename, filehandle, array ref or scalar ref"
- if ! $inType ;
-
- if ($inType eq 'filename' )
- {
- croak "$from: input filename is undef or null string"
- if ! defined $_[0] || $_[0] eq '' ;
-
- if ($_[0] ne '-' && ! -e $_[0] )
- {
- ${$_[1]} = "input file '$_[0]' does not exist";
- return undef;
- }
- }
-
- return 1;
-}
-
-sub ckOutputParam ($$$)
-{
- my $from = shift ;
- my $outType = whatIsOutput($_[0]);
- local $Carp::CarpLevel = 1;
-
- croak "$from: output parameter not a filename, filehandle or scalar ref"
- if ! $outType ;
-
- croak "$from: output filename is undef or null string"
- if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ;
-
- croak("$from: output buffer is read-only")
- if $outType eq 'buffer' && readonly(${ $_[0] });
-
- return 1;
-}
-
sub Validator::new
{
my $class = shift ;
my $Class = shift ;
- my $type = shift ;
my $error_ref = shift ;
my $reportClass = shift ;
my %data = (Class => $Class,
- Type => $type,
Error => $error_ref,
reportClass => $reportClass,
) ;
if (! $inType)
{
- croak "$reportClass: illegal input parameter" ;
+ $obj->croakError("$reportClass: illegal input parameter") ;
#return undef ;
}
- if ($inType eq 'hash')
- {
- $obj->{Hash} = 1 ;
- $obj->{oneInput} = 1 ;
- return $obj->validateHash($_[0]);
- }
+# if ($inType eq 'hash')
+# {
+# $obj->{Hash} = 1 ;
+# $obj->{oneInput} = 1 ;
+# return $obj->validateHash($_[0]);
+# }
if (! $outType)
{
- croak "$reportClass: illegal output parameter" ;
+ $obj->croakError("$reportClass: illegal output parameter") ;
#return undef ;
}
if ($inType ne 'fileglob' && $outType eq 'fileglob')
{
- ${ $data{Error} } = "Need input fileglob for outout fileglob";
- return undef ;
+ $obj->croakError("Need input fileglob for outout fileglob");
}
- if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
- {
- ${ $data{Error} } = "input must ne filename or fileglob when output is a hash";
- return undef ;
- }
+# if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
+# {
+# $obj->croakError("input must ne filename or fileglob when output is a hash");
+# }
if ($inType eq 'fileglob' && $outType eq 'fileglob')
{
my $mapper = new File::GlobMapper($_[0], $_[1]);
if ( ! $mapper )
{
- ${ $data{Error} } = $File::GlobMapper::Error ;
- return undef ;
+ return $obj->saveErrorString($File::GlobMapper::Error) ;
}
$data{Pairs} = $mapper->getFileMap();
return $obj;
}
- croak("$reportClass: input and output $inType are identical")
+ $obj->croakError("$reportClass: input and output $inType are identical")
if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
if ($inType eq 'fileglob') # && $outType ne 'fileglob'
if (@inputs == 0)
{
- # legal or die?
- die "legal or die???" ;
+ # TODO -- legal or die?
+ die "globmap matched zero file -- legal or die???" ;
}
elsif (@inputs == 1)
{
}
elsif ($inType eq 'array')
{
+ $data{inType} = 'filenames' ;
$obj->validateInputArray($_[0])
or return undef ;
}
- croak("$reportClass: output buffer is read-only")
- if $outType eq 'buffer' && Compress::Zlib::_readonly_ref($_[1]);
+ return $obj->saveErrorString("$reportClass: output buffer is read-only")
+ if $outType eq 'buffer' && readonly(${ $_[1] });
if ($outType eq 'filename' )
{
- croak "$reportClass: output filename is undef or null string"
+ $obj->croakError("$reportClass: output filename is undef or null string")
if ! defined $_[1] || $_[1] eq '' ;
}
return $obj ;
}
+sub Validator::saveErrorString
+{
+ my $self = shift ;
+ ${ $self->{Error} } = shift ;
+ return undef;
+
+}
+
+sub Validator::croakError
+{
+ my $self = shift ;
+ $self->saveErrorString($_[0]);
+ croak $_[0];
+}
+
+
sub Validator::validateInputFilenames
{
foreach my $filename (@_)
{
- croak "$self->{reportClass}: input filename is undef or null string"
+ $self->croakError("$self->{reportClass}: input filename is undef or null string")
if ! defined $filename || $filename eq '' ;
next if $filename eq '-';
if (! -e $filename )
{
- ${ $self->{Error} } = "input file '$filename' does not exist";
- return undef;
+ return $self->saveErrorString("input file '$filename' does not exist");
}
if (! -r $filename )
{
- ${ $self->{Error} } = "cannot open file '$filename': $!";
- return undef;
+ return $self->saveErrorString("cannot open file '$filename': $!");
}
}
{
my $self = shift ;
+ if ( @{ $_[0] } == 0 )
+ {
+ return $self->saveErrorString("empty array reference") ;
+ }
+
foreach my $element ( @{ $_[0] } )
{
my $inType = whatIsInput($element);
if (! $inType)
{
- ${ $self->{Error} } = "unknown input parameter" ;
- return undef ;
+ $self->croakError("unknown input parameter") ;
}
+ elsif($inType eq 'filename')
+ {
+ $self->validateInputFilenames($element)
+ or return undef ;
+ }
+ else
+ {
+ $self->croakError("not a filename") ;
+ }
}
return 1 ;
}
-sub Validator::validateHash
+#sub Validator::validateHash
+#{
+# my $self = shift ;
+# my $href = shift ;
+#
+# while (my($k, $v) = each %$href)
+# {
+# my $ktype = whatIsInput($k);
+# my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
+#
+# if ($ktype ne 'filename')
+# {
+# return $self->saveErrorString("hash key not filename") ;
+# }
+#
+# my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
+# if (! $valid{$vtype})
+# {
+# return $self->saveErrorString("hash value not ok") ;
+# }
+# }
+#
+# return $self ;
+#}
+
+sub createSelfTiedObject
{
- my $self = shift ;
- my $href = shift ;
-
- while (my($k, $v) = each %$href)
- {
- my $ktype = whatIsInput($k);
- my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
-
- if ($ktype ne 'filename')
- {
- ${ $self->{Error} } = "hash key not filename" ;
- return undef ;
- }
+ my $class = shift || (caller)[0] ;
+ my $error_ref = shift ;
- my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
- if (! $valid{$vtype})
- {
- ${ $self->{Error} } = "hash value not ok" ;
- return undef ;
- }
- }
+ my $obj = bless Symbol::gensym(), ref($class) || $class;
+ tie *$obj, $obj if $] >= 5.005;
+ *$obj->{Closed} = 1 ;
+ $$error_ref = '';
+ *$obj->{Error} = $error_ref ;
+ my $errno = 0 ;
+ *$obj->{ErrorNo} = \$errno ;
- return $self ;
+ return $obj;
}
+
1;
our ($VERSION, @ISA, @EXPORT);
-$VERSION = '2.000_05';
+$VERSION = '2.000_07';
@ISA = qw(Exporter);
require Exporter;
our ($VERSION, @ISA, @EXPORT);
-$VERSION = '2.000_05';
+$VERSION = '2.000_07';
@ISA = qw(Exporter);
use constant Parse_any => 0x01;
use constant OFF_TYPE => 1 ;
use constant OFF_DEFAULT => 2 ;
use constant OFF_FIXED => 3 ;
+use constant OFF_FIRST_ONLY => 4 ;
+use constant OFF_STICKY => 5 ;
push @EXPORT, qw( ParseParameters
Parse_any Parse_unsigned Parse_signed
sub new
{
my $class = shift ;
+
my $obj = { Error => '',
Got => {},
} ;
my $default = shift ;
+ my $got = $self->{Got} ;
+ my $firstTime = keys %{ $got } == 0 ;
+
my (@Bad) ;
my @entered = () ;
}
- my %got = () ;
while (my ($key, $v) = each %$default)
{
- my ($type, $value) = @$v ;
+ croak "need 4 params [@$v]"
+ if @$v != 4 ;
+
+ my ($first_only, $sticky, $type, $value) = @$v ;
my $x ;
$self->_checkType($key, \$value, $type, 0, \$x)
or return undef ;
- $got{lc $key} = [0, $type, $value, $x] ;
+
+ $key = lc $key;
+
+ if ($firstTime || ! $sticky) {
+ $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
+ }
+
+ $got->{$key}[OFF_PARSED] = 0 ;
}
for my $i (0.. @entered / 2 - 1) {
#print defined $$value ? "[$$value]\n" : "[undef]\n";
$key =~ s/^-// ;
+ my $canonkey = lc $key;
- if ($got{lc $key})
+ if ($got->{$canonkey} && ($firstTime ||
+ ! $got->{$canonkey}[OFF_FIRST_ONLY] ))
{
- my $type = $got{lc $key}[OFF_TYPE] ;
+ my $type = $got->{$canonkey}[OFF_TYPE] ;
my $s ;
$self->_checkType($key, $value, $type, 1, \$s)
or return undef ;
#$value = $$value unless $type & Parse_store_ref ;
$value = $$value ;
- $got{lc $key} = [1, $type, $value, $s] ;
+ $got->{$canonkey} = [1, $type, $value, $s] ;
}
else
{ push (@Bad, $key) }
return $self->setError("unknown key value(s) @Bad") ;
}
- $self->{Got} = { %got } ;
-
return 1;
}
}
elsif ($type & Parse_unsigned)
{
- return $self->setError("Parameter '$key' must be an unsigned int, got undef")
+ return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
if $validate && ! defined $value ;
return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
if $validate && $value !~ /^\d+$/;
}
elsif ($type & Parse_signed)
{
- return $self->setError("Parameter '$key' must be a signed int, got undef")
+ return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
if $validate && ! defined $value ;
return $self->setError("Parameter '$key' must be a signed int, got '$value'")
if $validate && $value !~ /^-?\d+$/;
}
elsif ($type & Parse_boolean)
{
+ return $self->setError("Parameter '$key' must be an int, got '$value'")
+ if $validate && defined $value && $value !~ /^\d*$/;
$$output = defined $value ? $value != 0 : 0 ;
return 1;
}
}
+sub clone
+{
+ my $self = shift ;
+ my $obj = { };
+ my %got ;
+
+ while (my ($k, $v) = each %{ $self->{Got} }) {
+ $got{$k} = [ @$v ];
+ }
+
+ $obj->{Error} = $self->{Error};
+ $obj->{Got} = \%got ;
+
+ return bless $obj ;
+}
+
1;
--- /dev/null
+package CompressPlugin::Deflate ;
+
+use strict;
+use warnings;
+
+use Compress::Zlib::Common qw(:Status);
+
+use Compress::Zlib qw(Z_OK Z_FINISH MAX_WBITS) ;
+our ($VERSION);
+
+$VERSION = '2.000_05';
+
+sub mkCompObject
+{
+ my $crc32 = shift ;
+ my $adler32 = shift ;
+ my $level = shift ;
+ my $strategy = shift ;
+
+ my ($def, $status) = new Compress::Zlib::Deflate
+ -AppendOutput => 1,
+ -CRC32 => $crc32,
+ -ADLER32 => $adler32,
+ -Level => $level,
+ -Strategy => $strategy,
+ -WindowBits => - MAX_WBITS;
+
+ return (undef, "Cannot create Deflate object: $status", $status)
+ if $status != Z_OK;
+
+ return bless {'Def' => $def,
+ 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'Error' => '',
+ } ;
+}
+
+sub compr
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ my $status = $def->deflate($_[0], $_[1]) ;
+ $self->{ErrorNo} = $status;
+
+ if ($status != Z_OK)
+ {
+ $self->{Error} = "Deflate Error: $status";
+ return STATUS_ERROR;
+ }
+
+ return STATUS_OK;
+}
+
+sub flush
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ my $opt = $_[1] || Z_FINISH;
+ my $status = $def->flush($_[0], $opt);
+ $self->{ErrorNo} = $status;
+
+ if ($status != Z_OK)
+ {
+ $self->{Error} = "Deflate Error: $status";
+ return STATUS_ERROR;
+ }
+
+ return STATUS_OK;
+
+}
+
+sub close
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ $def->flush($_[0], Z_FINISH);
+}
+
+sub reset
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ my $status = $def->deflateReset() ;
+ $self->{ErrorNo} = $status;
+ if ($status != Z_OK)
+ {
+ $self->{Error} = "Deflate Error: $status";
+ return STATUS_ERROR;
+ }
+
+ return STATUS_OK;
+}
+
+sub deflateParams
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ my $status = $def->deflateParams(@_);
+ $self->{ErrorNo} = $status;
+ if ($status != Z_OK)
+ {
+ $self->{Error} = "deflateParams Error: $status";
+ return STATUS_ERROR;
+ }
+
+ return STATUS_OK;
+}
+
+
+
+sub total_out
+{
+ my $self = shift ;
+ $self->{Def}->total_out();
+}
+
+sub total_in
+{
+ my $self = shift ;
+ $self->{Def}->total_in();
+}
+
+sub compressedBytes
+{
+ my $self = shift ;
+ $self->{Def}->compressedBytes();
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ $self->{Def}->uncompressedBytes();
+}
+
+
+
+
+sub crc32
+{
+ my $self = shift ;
+ $self->{Def}->crc32();
+}
+
+sub adler32
+{
+ my $self = shift ;
+ $self->{Def}->adler32();
+}
+
+
+1;
+
+__END__
+
--- /dev/null
+package CompressPlugin::Identity ;
+
+use strict;
+use warnings;
+
+use Compress::Zlib::Common qw(:Status);
+use Compress::Zlib () ;
+our ($VERSION);
+
+$VERSION = '2.000_05';
+
+sub mkCompObject
+{
+ my $crc32 = shift ;
+ my $adler32 = shift ;
+ my $level = shift ;
+ my $strategy = shift ;
+
+ return bless {
+ 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'Error' => '',
+ 'ErrorNo' => 0,
+ 'wantCRC32' => $crc32,
+ 'CRC32' => Compress::Zlib::crc32(''),
+ 'wantADLER32'=> $adler32,
+ 'ADLER32' => Compress::Zlib::adler32(''),
+ } ;
+}
+
+sub compr
+{
+ my $self = shift ;
+
+ if (defined ${ $_[0] } && length ${ $_[0] }) {
+ $self->{CompSize} += length ${ $_[0] } ;
+ $self->{UnCompSize} = $self->{CompSize} ;
+
+ $self->{CRC32} = Compress::Zlib::crc32($_[0], $self->{CRC32})
+ if $self->{wantCRC32};
+
+ $self->{ADLER32} = Compress::Zlib::adler32($_[0], $self->{ADLER32})
+ if $self->{wantADLER32};
+
+ ${ $_[1] } .= ${ $_[0] };
+ }
+
+ return STATUS_OK ;
+}
+
+sub flush
+{
+ my $self = shift ;
+
+ return STATUS_OK;
+}
+
+sub close
+{
+ my $self = shift ;
+
+ return STATUS_OK;
+}
+
+sub reset
+{
+ my $self = shift ;
+
+ return STATUS_OK;
+}
+
+sub deflateParams
+{
+ my $self = shift ;
+
+ return STATUS_OK;
+}
+
+sub total_out
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub total_in
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub compressedBytes
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub crc32
+{
+ my $self = shift ;
+ return $self->{CRC32};
+}
+
+sub adler32
+{
+ my $self = shift ;
+ return $self->{ADLER32};
+}
+
+
+
+1;
+
+
+__END__
+
{
require File::BSDGlob; import File::BSDGlob qw(:glob) ;
$CSH_GLOB = File::BSDGlob::GLOB_CSH() ;
- *globber = \&File::BSDGlob::glob;
+ *globber = \&File::BSDGlob::csh_glob;
}
else
{
require File::Glob; import File::Glob qw(:glob) ;
$CSH_GLOB = File::Glob::GLOB_CSH() ;
#*globber = \&File::Glob::bsd_glob;
- *globber = \&File::Glob::glob;
+ *globber = \&File::Glob::csh_glob;
}
}
To help explain what C<File::GlobMapper> does, consider what code you
would write if you wanted to rename all files in the current directory
that ended in C<.tar.gz> to C<.tgz>. So say these files are in the
-current directoty
+current directory
alpha.tar.gz
beta.tar.gz
file glob to match existing filenames followed by a substitute
to create the new filenames.
-Notice how both parameters to C<globmap> are strings that are delimired by <>.
+Notice how both parameters to C<globmap> are strings that are delimited by <>.
This is done to make them look more like file globs - it is just syntactic
sugar, but it can be handy when you want the strings to be visually
distinctive. The enclosing <> are optional, so you don't have to use them - in
-fact the first thing globmap will do is remove these delimeters if they are
+fact the first thing globmap will do is remove these delimiters if they are
present.
The first parameter to C<globmap>, C<*.tar.gz>, is an I<Input File Glob>.
C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to
solve all filename mapping operations. Under the hood C<File::Glob> (or for
-older verions of Perl, C<File::BSDGlob>) is used to match the files, so you
+older versions of Perl, C<File::BSDGlob>) is used to match the files, so you
will never have the flexibility of full Perl regular expression.
=head2 Input File Glob
=item "*"
-The "*" chanacter will be replaced with the complete input filename.
+The "*" character will be replaced with the complete input filename.
=item #1
=head2 A few example globmaps
-Below are a few examles of globmaps
+Below are a few examples of globmaps
To copy all your .c file to a backup directory
--- /dev/null
+
+package IO::Compress::Base ;
+
+require 5.004 ;
+
+use strict ;
+use warnings;
+
+use Compress::Zlib::Common;
+use Compress::Zlib::ParseParameters;
+
+use IO::File ;
+use Scalar::Util qw(blessed readonly);
+
+#use File::Glob;
+#require Exporter ;
+use Carp ;
+use Symbol;
+use bytes;
+
+our (@ISA, $VERSION, $got_encode);
+@ISA = qw(Exporter IO::File);
+
+$VERSION = '2.000_05';
+
+#Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16.
+
+#$got_encode = 0;
+#eval
+#{
+# require Encode;
+# Encode->import('encode', 'find_encoding');
+#};
+#
+#$got_encode = 1 unless $@;
+
+sub saveStatus
+{
+ my $self = shift ;
+ ${ *$self->{ErrorNo} } = shift() + 0 ;
+ ${ *$self->{Error} } = '' ;
+
+ return ${ *$self->{ErrorNo} } ;
+}
+
+
+sub saveErrorString
+{
+ my $self = shift ;
+ my $retval = shift ;
+ ${ *$self->{Error} } = shift ;
+ ${ *$self->{ErrorNo} } = shift() + 0 if @_ ;
+
+ return $retval;
+}
+
+sub croakError
+{
+ my $self = shift ;
+ $self->saveErrorString(0, $_[0]);
+ croak $_[0];
+}
+
+sub closeError
+{
+ my $self = shift ;
+ my $retval = shift ;
+
+ my $errno = *$self->{ErrorNo};
+ my $error = ${ *$self->{Error} };
+
+ $self->close();
+
+ *$self->{ErrorNo} = $errno ;
+ ${ *$self->{Error} } = $error ;
+
+ return $retval;
+}
+
+
+
+sub error
+{
+ my $self = shift ;
+ return ${ *$self->{Error} } ;
+}
+
+sub errorNo
+{
+ my $self = shift ;
+ return ${ *$self->{ErrorNo} } ;
+}
+
+
+sub writeAt
+{
+ my $self = shift ;
+ my $offset = shift;
+ my $data = shift;
+
+ if (defined *$self->{FH}) {
+ my $here = tell(*$self->{FH});
+ return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!)
+ if $here < 0 ;
+ seek(*$self->{FH}, $offset, SEEK_SET)
+ or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
+ defined *$self->{FH}->write($data, length $data)
+ or return $self->saveErrorString(undef, $!, $!) ;
+ seek(*$self->{FH}, $here, SEEK_SET)
+ or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
+ }
+ else {
+ substr(${ *$self->{Buffer} }, $offset, length($data)) = $data ;
+ }
+
+ return 1;
+}
+
+sub getOneShotParams
+{
+ return ( 'MultiStream' => [1, 1, Parse_boolean, 1],
+ );
+}
+
+sub checkParams
+{
+ my $self = shift ;
+ my $class = shift ;
+
+ my $got = shift || Compress::Zlib::ParseParameters::new();
+
+ $got->parse(
+ {
+ # Generic Parameters
+ 'AutoClose' => [1, 1, Parse_boolean, 0],
+ #'Encoding' => [1, 1, Parse_any, undef],
+ 'Strict' => [0, 1, Parse_boolean, 1],
+ 'Append' => [1, 1, Parse_boolean, 0],
+ 'BinModeIn' => [1, 1, Parse_boolean, 0],
+
+ $self->getExtraParams(),
+ *$self->{OneShot} ? $self->getOneShotParams()
+ : (),
+ },
+ @_) or $self->croakError("${class}: $got->{Error}") ;
+
+ return $got ;
+}
+
+sub _create
+{
+ my $obj = shift;
+ my $got = shift;
+
+ *$obj->{Closed} = 1 ;
+
+ my $class = ref $obj;
+ $obj->croakError("$class: Missing Output parameter")
+ if ! @_ && ! $got ;
+
+ my $outValue = shift ;
+ my $oneShot = 1 ;
+
+ if (! $got)
+ {
+ $oneShot = 0 ;
+ $got = $obj->checkParams($class, undef, @_)
+ or return undef ;
+ }
+
+ my $lax = ! $got->value('Strict') ;
+
+ my $outType = whatIsOutput($outValue);
+
+ $obj->ckOutputParam($class, $outValue)
+ or return undef ;
+
+ if ($outType eq 'buffer') {
+ *$obj->{Buffer} = $outValue;
+ }
+ else {
+ my $buff = "" ;
+ *$obj->{Buffer} = \$buff ;
+ }
+
+ # Merge implies Append
+ my $merge = $got->value('Merge') ;
+ my $appendOutput = $got->value('Append') || $merge ;
+
+ if ($merge)
+ {
+ # Switch off Merge mode if output file/buffer is empty/doesn't exist
+ if (($outType eq 'buffer' && length $$outValue == 0 ) ||
+ ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) )
+ { $merge = 0 }
+ }
+
+ # If output is a file, check that it is writable
+ if ($outType eq 'filename' && -e $outValue && ! -w _)
+ { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) }
+
+ elsif ($outType eq 'handle' && ! -w $outValue)
+ { return $obj->saveErrorString(undef, "Output filehandle is not writable" ) }
+
+
+# TODO - encoding
+# if ($got->parsed('Encoding')) {
+# $obj->croakError("$class: Encode module needed to use -Encoding")
+# if ! $got_encode;
+#
+# my $want_encoding = $got->value('Encoding');
+# my $encoding = find_encoding($want_encoding);
+#
+# $obj->croakError("$class: Encoding '$want_encoding' is not available")
+# if ! $encoding;
+#
+# *$obj->{Encoding} = $encoding;
+# }
+
+ $obj->ckParams($got)
+ or $obj->croakError("${class}: " . $obj->error());
+
+
+ $obj->saveStatus(STATUS_OK) ;
+
+ my $status ;
+ if (! $merge)
+ {
+ *$obj->{Compress} = $obj->mkComp($class, $got)
+ or return undef;
+
+ *$obj->{BytesWritten} = 0 ;
+ *$obj->{UnCompSize_32bit} = 0 ;
+
+ *$obj->{Header} = $obj->mkHeader($got) ;
+
+ if ( $outType eq 'buffer') {
+ ${ *$obj->{Buffer} } = ''
+ unless $appendOutput ;
+ ${ *$obj->{Buffer} } .= *$obj->{Header};
+ }
+ else {
+ if ($outType eq 'handle') {
+ *$obj->{FH} = $outValue ;
+ setBinModeOutput(*$obj->{FH}) ;
+ $outValue->flush() ;
+ *$obj->{Handle} = 1 ;
+ if ($appendOutput)
+ {
+ seek(*$obj->{FH}, 0, SEEK_END)
+ or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
+
+ }
+ }
+ elsif ($outType eq 'filename') {
+ my $mode = '>' ;
+ $mode = '>>'
+ if $appendOutput;
+ *$obj->{FH} = new IO::File "$mode $outValue"
+ or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ;
+ *$obj->{StdIO} = ($outValue eq '-');
+ setBinModeOutput(*$obj->{FH}) ;
+ }
+
+
+ if (length *$obj->{Header}) {
+ defined *$obj->{FH}->write(*$obj->{Header}, length(*$obj->{Header}))
+ or return $obj->saveErrorString(undef, $!, $!) ;
+ }
+ }
+ }
+ else
+ {
+ *$obj->{Compress} = $obj->createMerge($outValue, $outType)
+ or return undef;
+ }
+
+ *$obj->{Closed} = 0 ;
+ *$obj->{AutoClose} = $got->value('AutoClose') ;
+ *$obj->{Output} = $outValue;
+ *$obj->{ClassName} = $class;
+ *$obj->{Got} = $got;
+ *$obj->{OneShot} = 0 ;
+
+ return $obj ;
+}
+
+sub ckOutputParam
+{
+ my $self = shift ;
+ my $from = shift ;
+ my $outType = whatIsOutput($_[0]);
+
+ $self->croakError("$from: output parameter not a filename, filehandle or scalar ref")
+ if ! $outType ;
+
+ $self->croakError("$from: output filename is undef or null string")
+ if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ;
+
+ $self->croakError("$from: output buffer is read-only")
+ if $outType eq 'buffer' && readonly(${ $_[0] });
+
+ return 1;
+}
+
+
+sub _def
+{
+ my $obj = shift ;
+
+ my $class= (caller)[0] ;
+ my $name = (caller(1))[3] ;
+
+ $obj->croakError("$name: expected at least 1 parameters\n")
+ unless @_ >= 1 ;
+
+ my $input = shift ;
+ my $haveOut = @_ ;
+ my $output = shift ;
+
+ my $x = new Validator($class, *$obj->{Error}, $name, $input, $output)
+ or return undef ;
+
+ push @_, $output if $haveOut && $x->{Hash};
+
+ *$obj->{OneShot} = 1 ;
+
+ my $got = $obj->checkParams($name, undef, @_)
+ or return undef ;
+
+ $x->{Got} = $got ;
+
+# if ($x->{Hash})
+# {
+# while (my($k, $v) = each %$input)
+# {
+# $v = \$input->{$k}
+# unless defined $v ;
+#
+# $obj->_singleTarget($x, 1, $k, $v, @_)
+# or return undef ;
+# }
+#
+# return keys %$input ;
+# }
+
+ if ($x->{GlobMap})
+ {
+ $x->{oneInput} = 1 ;
+ foreach my $pair (@{ $x->{Pairs} })
+ {
+ my ($from, $to) = @$pair ;
+ $obj->_singleTarget($x, 1, $from, $to, @_)
+ or return undef ;
+ }
+
+ return scalar @{ $x->{Pairs} } ;
+ }
+
+ if (! $x->{oneOutput} )
+ {
+ my $inFile = ($x->{inType} eq 'filenames'
+ || $x->{inType} eq 'filename');
+
+ $x->{inType} = $inFile ? 'filename' : 'buffer';
+
+ foreach my $in ($x->{oneInput} ? $input : @$input)
+ {
+ my $out ;
+ $x->{oneInput} = 1 ;
+
+ $obj->_singleTarget($x, $inFile, $in, \$out, @_)
+ or return undef ;
+
+ push @$output, \$out ;
+ #if ($x->{outType} eq 'array')
+ # { push @$output, \$out }
+ #else
+ # { $output->{$in} = \$out }
+ }
+
+ return 1 ;
+ }
+
+ # finally the 1 to 1 and n to 1
+ return $obj->_singleTarget($x, 1, $input, $output, @_);
+
+ croak "should not be here" ;
+}
+
+sub _singleTarget
+{
+ my $obj = shift ;
+ my $x = shift ;
+ my $inputIsFilename = shift;
+ my $input = shift;
+
+ if ($x->{oneInput})
+ {
+ $obj->getFileInfo($x->{Got}, $input)
+ if isaFilename($input) and $inputIsFilename ;
+
+ my $z = $obj->_create($x->{Got}, @_)
+ or return undef ;
+
+
+ defined $z->_wr2($input, $inputIsFilename)
+ or return $z->closeError(undef) ;
+
+ return $z->close() ;
+ }
+ else
+ {
+ my $afterFirst = 0 ;
+ my $inputIsFilename = ($x->{inType} ne 'array');
+ my $keep = $x->{Got}->clone();
+
+ #for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
+ for my $element ( @$input)
+ {
+ my $isFilename = isaFilename($element);
+
+ if ( $afterFirst ++ )
+ {
+ defined addInterStream($obj, $element, $isFilename)
+ or return $obj->closeError(undef) ;
+ }
+ else
+ {
+ $obj->getFileInfo($x->{Got}, $element)
+ if $isFilename;
+
+ $obj->_create($x->{Got}, @_)
+ or return undef ;
+ }
+
+ defined $obj->_wr2($element, $isFilename)
+ or return $obj->closeError(undef) ;
+
+ *$obj->{Got} = $keep->clone();
+ }
+ return $obj->close() ;
+ }
+
+}
+
+sub _wr2
+{
+ my $self = shift ;
+
+ my $source = shift ;
+ my $inputIsFilename = shift;
+
+ my $input = $source ;
+ if (! $inputIsFilename)
+ {
+ $input = \$source
+ if ! ref $source;
+ }
+
+ if ( ref $input && ref $input eq 'SCALAR' )
+ {
+ return $self->syswrite($input, @_) ;
+ }
+
+ if ( ! ref $input || isaFilehandle($input))
+ {
+ my $isFilehandle = isaFilehandle($input) ;
+
+ my $fh = $input ;
+
+ if ( ! $isFilehandle )
+ {
+ $fh = new IO::File "<$input"
+ or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ;
+ }
+ binmode $fh if *$self->{Got}->valueOrDefault('BinModeIn') ;
+
+ my $status ;
+ my $buff ;
+ my $count = 0 ;
+ while (($status = read($fh, $buff, 4096)) > 0) {
+ $count += length $buff;
+ defined $self->syswrite($buff, @_)
+ or return undef ;
+ }
+
+ return $self->saveErrorString(undef, $!, $!)
+ if $status < 0 ;
+
+ if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-')
+ {
+ $fh->close()
+ or return undef ;
+ }
+
+ return $count ;
+ }
+
+ croak "Should not be here";
+ return undef;
+}
+
+sub addInterStream
+{
+ my $self = shift ;
+ my $input = shift ;
+ my $inputIsFilename = shift ;
+
+ if (*$self->{Got}->value('MultiStream'))
+ {
+ $self->getFileInfo(*$self->{Got}, $input)
+ #if isaFilename($input) and $inputIsFilename ;
+ if isaFilename($input) ;
+
+ # TODO -- newStream needs to allow gzip/zip header to be modified
+ return $self->newStream();
+ }
+ elsif (*$self->{Got}->value('AutoFlush'))
+ {
+ #return $self->flush(Z_FULL_FLUSH);
+ }
+
+ return 1 ;
+}
+
+sub TIEHANDLE
+{
+ return $_[0] if ref($_[0]);
+ die "OOPS\n" ;
+}
+
+sub UNTIE
+{
+ my $self = shift ;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->close() ;
+
+ # TODO - memory leak with 5.8.0 - this isn't called until
+ # global destruction
+ #
+ %{ *$self } = () ;
+ undef $self ;
+}
+
+
+
+sub syswrite
+{
+ my $self = shift ;
+
+ my $buffer ;
+ if (ref $_[0] ) {
+ $self->croakError( *$self->{ClassName} . "::write: not a scalar reference" )
+ unless ref $_[0] eq 'SCALAR' ;
+ $buffer = $_[0] ;
+ }
+ else {
+ $buffer = \$_[0] ;
+ }
+
+
+ if (@_ > 1) {
+ my $slen = defined $$buffer ? length($$buffer) : 0;
+ my $len = $slen;
+ my $offset = 0;
+ $len = $_[1] if $_[1] < $len;
+
+ if (@_ > 2) {
+ $offset = $_[2] || 0;
+ $self->croakError(*$self->{ClassName} . "::write: offset outside string")
+ if $offset > $slen;
+ if ($offset < 0) {
+ $offset += $slen;
+ $self->croakError( *$self->{ClassName} . "::write: offset outside string") if $offset < 0;
+ }
+ my $rem = $slen - $offset;
+ $len = $rem if $rem < $len;
+ }
+
+ $buffer = \substr($$buffer, $offset, $len) ;
+ }
+
+ return 0 if ! defined $$buffer || length $$buffer == 0 ;
+
+ my $buffer_length = defined $$buffer ? length($$buffer) : 0 ;
+ *$self->{BytesWritten} += $buffer_length ;
+ my $rest = 0xFFFFFFFF - *$self->{UnCompSize_32bit} ;
+ if ($buffer_length > $rest) {
+ *$self->{UnCompSize_32bit} = $buffer_length - $rest - 1;
+ }
+ else {
+ *$self->{UnCompSize_32bit} += $buffer_length ;
+ }
+
+# if (*$self->{Encoding}) {
+# $$buffer = *$self->{Encoding}->encode($$buffer);
+# }
+
+ #my $length = length $$buffer;
+ my $status = *$self->{Compress}->compr($buffer, *$self->{Buffer}) ;
+
+ return $self->saveErrorString(undef, *$self->{Compress}{Error},
+ *$self->{Compress}{ErrorNo})
+ if $status == STATUS_ERROR;
+
+
+
+ if ( defined *$self->{FH} and length ${ *$self->{Buffer} }) {
+ defined *$self->{FH}->write( ${ *$self->{Buffer} }, length ${ *$self->{Buffer} } )
+ or return $self->saveErrorString(undef, $!, $!);
+ ${ *$self->{Buffer} } = '' ;
+ }
+
+ return $buffer_length;
+}
+
+sub print
+{
+ my $self = shift;
+
+ #if (ref $self) {
+ # $self = *$self{GLOB} ;
+ #}
+
+ if (defined $\) {
+ if (defined $,) {
+ defined $self->syswrite(join($,, @_) . $\);
+ } else {
+ defined $self->syswrite(join("", @_) . $\);
+ }
+ } else {
+ if (defined $,) {
+ defined $self->syswrite(join($,, @_));
+ } else {
+ defined $self->syswrite(join("", @_));
+ }
+ }
+}
+
+sub printf
+{
+ my $self = shift;
+ my $fmt = shift;
+ defined $self->syswrite(sprintf($fmt, @_));
+}
+
+
+
+sub flush
+{
+ my $self = shift ;
+ my $opt = shift ;
+
+ my $status = *$self->{Compress}->flush(*$self->{Buffer}, $opt) ;
+ return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo})
+ if $status == STATUS_ERROR;
+
+ if ( defined *$self->{FH} ) {
+ *$self->{FH}->clearerr();
+ defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} })
+ or return $self->saveErrorString(0, $!, $!);
+ ${ *$self->{Buffer} } = '' ;
+ }
+
+ return 1;
+}
+
+sub newStream
+{
+ my $self = shift ;
+
+ $self->_writeTrailer()
+ or return 0 ;
+
+ my $got = $self->checkParams('newStream', *$self->{Got}, @_)
+ or return 0 ;
+
+ $self->ckParams($got)
+ or $self->croakError("newStream: $self->{Error}");
+
+ *$self->{Header} = $self->mkHeader($got) ;
+ ${ *$self->{Buffer} } .= *$self->{Header} ;
+
+ if (defined *$self->{FH})
+ {
+ defined *$self->{FH}->write(${ *$self->{Buffer} },
+ length ${ *$self->{Buffer} })
+ or return $self->saveErrorString(0, $!, $!);
+ ${ *$self->{Buffer} } = '' ;
+ }
+
+ my $status = *$self->{Compress}->reset() ;
+ return $self->saveErrorString(0, *$self->{Compress}{Error},
+ *$self->{Compress}{ErrorNo})
+ if $status == STATUS_ERROR;
+
+ *$self->{BytesWritten} = 0 ;
+ *$self->{UnCompSize_32bit} = 0 ;
+
+ return 1 ;
+}
+
+sub _writeTrailer
+{
+ my $self = shift ;
+
+ my $status = *$self->{Compress}->close(*$self->{Buffer}) ;
+ return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo})
+ if $status == STATUS_ERROR;
+
+ my $trailer = $self->mkTrailer();
+ defined $trailer
+ or return 0;
+
+ ${ *$self->{Buffer} } .= $trailer;
+
+ return 1 if ! defined *$self->{FH} ;
+
+ defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} })
+ or return $self->saveErrorString(0, $!, $!);
+
+ ${ *$self->{Buffer} } = '' ;
+
+ return 1;
+}
+
+sub _writeFinalTrailer
+{
+ my $self = shift ;
+
+ ${ *$self->{Buffer} } .= $self->mkFinalTrailer();
+
+ return 1 if ! defined *$self->{FH} ;
+
+ defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} })
+ or return $self->saveErrorString(0, $!, $!);
+
+ ${ *$self->{Buffer} } = '' ;
+
+ return 1;
+}
+
+sub close
+{
+ my $self = shift ;
+
+ return 1 if *$self->{Closed} || ! *$self->{Compress} ;
+ *$self->{Closed} = 1 ;
+
+ untie *$self
+ if $] >= 5.008 ;
+
+ $self->_writeTrailer()
+ or return 0 ;
+
+ $self->_writeFinalTrailer()
+ or return 0 ;
+
+ if (defined *$self->{FH}) {
+ #if (! *$self->{Handle} || *$self->{AutoClose}) {
+ if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
+ $! = 0 ;
+ *$self->{FH}->close()
+ or return $self->saveErrorString(0, $!, $!);
+ }
+ delete *$self->{FH} ;
+ # This delete can set $! in older Perls, so reset the errno
+ $! = 0 ;
+ }
+
+ return 1;
+}
+
+
+#sub total_in
+#sub total_out
+#sub msg
+#
+#sub crc
+#{
+# my $self = shift ;
+# return *$self->{Compress}->crc32() ;
+#}
+#
+#sub msg
+#{
+# my $self = shift ;
+# return *$self->{Compress}->msg() ;
+#}
+#
+#sub dict_adler
+#{
+# my $self = shift ;
+# return *$self->{Compress}->dict_adler() ;
+#}
+#
+#sub get_Level
+#{
+# my $self = shift ;
+# return *$self->{Compress}->get_Level() ;
+#}
+#
+#sub get_Strategy
+#{
+# my $self = shift ;
+# return *$self->{Compress}->get_Strategy() ;
+#}
+
+
+sub tell
+{
+ my $self = shift ;
+
+ #return *$self->{Compress}->total_in();
+ return *$self->{BytesWritten} ;
+}
+
+sub eof
+{
+ my $self = shift ;
+
+ return *$self->{Closed} ;
+}
+
+
+sub seek
+{
+ my $self = shift ;
+ my $position = shift;
+ my $whence = shift ;
+
+ my $here = $self->tell() ;
+ my $target = 0 ;
+
+ #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+ use IO::Handle ;
+
+ if ($whence == IO::Handle::SEEK_SET) {
+ $target = $position ;
+ }
+ elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) {
+ $target = $here + $position ;
+ }
+ else {
+ $self->croakError(*$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter");
+ }
+
+ # short circuit if seeking to current offset
+ return 1 if $target == $here ;
+
+ # Outlaw any attempt to seek backwards
+ $self->croakError(*$self->{ClassName} . "::seek: cannot seek backwards")
+ if $target < $here ;
+
+ # Walk the file to the new offset
+ my $offset = $target - $here ;
+
+ my $buffer ;
+ defined $self->syswrite("\x00" x $offset)
+ or return 0;
+
+ return 1 ;
+}
+
+sub binmode
+{
+ 1;
+# my $self = shift ;
+# return defined *$self->{FH}
+# ? binmode *$self->{FH}
+# : 1 ;
+}
+
+sub fileno
+{
+ my $self = shift ;
+ return defined *$self->{FH}
+ ? *$self->{FH}->fileno()
+ : undef ;
+}
+
+sub _notAvailable
+{
+ my $name = shift ;
+ return sub { croak "$name Not Available: File opened only for output" ; } ;
+}
+
+*read = _notAvailable('read');
+*READ = _notAvailable('read');
+*readline = _notAvailable('readline');
+*READLINE = _notAvailable('readline');
+*getc = _notAvailable('getc');
+*GETC = _notAvailable('getc');
+
+*FILENO = \&fileno;
+*PRINT = \&print;
+*PRINTF = \&printf;
+*WRITE = \&syswrite;
+*write = \&syswrite;
+*SEEK = \&seek;
+*TELL = \&tell;
+*EOF = \&eof;
+*CLOSE = \&close;
+*BINMODE = \&binmode;
+
+#*sysread = \&_notAvailable;
+#*syswrite = \&_write;
+
+1;
+
+__END__
+
use strict ;
use warnings;
+
require Exporter ;
-use IO::Compress::Gzip ;
+use IO::Compress::RawDeflate;
+
+use Compress::Zlib 2 ;
+use Compress::Zlib::FileConstants;
+use Compress::Zlib::Common qw(createSelfTiedObject);
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError);
-$VERSION = '2.000_05';
+$VERSION = '2.000_07';
$DeflateError = '';
-@ISA = qw(Exporter IO::BaseDeflate);
+@ISA = qw(Exporter IO::Compress::RawDeflate);
@EXPORT_OK = qw( $DeflateError deflate ) ;
-%EXPORT_TAGS = %IO::BaseDeflate::EXPORT_TAGS ;
+%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
-
sub new
{
- my $pkg = shift ;
- return IO::BaseDeflate::new($pkg, 'rfc1950', undef, \$DeflateError, @_);
+ my $class = shift ;
+
+ my $obj = createSelfTiedObject($class, \$DeflateError);
+ return $obj->_create(undef, @_);
}
sub deflate
{
- return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1950', \$DeflateError, @_);
+ my $obj = createSelfTiedObject(undef, \$DeflateError);
+ return $obj->_def(@_);
+}
+
+
+sub bitmask($$$$)
+{
+ my $into = shift ;
+ my $value = shift ;
+ my $offset = shift ;
+ my $mask = shift ;
+
+ return $into | (($value & $mask) << $offset ) ;
}
+sub mkDeflateHdr($$$;$)
+{
+ my $method = shift ;
+ my $cinfo = shift;
+ my $level = shift;
+ my $fdict_adler = shift ;
+
+ my $cmf = 0;
+ my $flg = 0;
+ my $fdict = 0;
+ $fdict = 1 if defined $fdict_adler;
+
+ $cmf = bitmask($cmf, $method, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS);
+ $cmf = bitmask($cmf, $cinfo, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS);
+
+ $flg = bitmask($flg, $fdict, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS);
+ $flg = bitmask($flg, $level, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS);
+
+ my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ;
+ $flg = bitmask($flg, $fcheck, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS);
+
+ my $hdr = pack("CC", $cmf, $flg) ;
+ $hdr .= pack("N", $fdict_adler) if $fdict ;
+
+ return $hdr;
+}
+
+sub mkHeader
+{
+ my $self = shift ;
+ my $param = shift ;
+
+ my $level = $param->value('Level');
+ my $strategy = $param->value('Strategy');
+
+ my $lflag ;
+ $level = 6
+ if $level == Z_DEFAULT_COMPRESSION ;
+
+ if (ZLIB_VERNUM >= 0x1210)
+ {
+ if ($strategy >= Z_HUFFMAN_ONLY || $level < 2)
+ { $lflag = ZLIB_FLG_LEVEL_FASTEST }
+ elsif ($level < 6)
+ { $lflag = ZLIB_FLG_LEVEL_FAST }
+ elsif ($level == 6)
+ { $lflag = ZLIB_FLG_LEVEL_DEFAULT }
+ else
+ { $lflag = ZLIB_FLG_LEVEL_SLOWEST }
+ }
+ else
+ {
+ $lflag = ($level - 1) >> 1 ;
+ $lflag = 3 if $lflag > 3 ;
+ }
+
+ #my $wbits = (MAX_WBITS - 8) << 4 ;
+ my $wbits = 7;
+ mkDeflateHdr(ZLIB_CMF_CM_DEFLATED, $wbits, $lflag);
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift;
+
+ $got->value('ADLER32' => 1);
+ return 1 ;
+}
+
+
+sub mkTrailer
+{
+ my $self = shift ;
+ return pack("N", *$self->{Compress}->adler32()) ;
+}
+
+sub mkFinalTrailer
+{
+ return '';
+}
+
+#sub newHeader
+#{
+# my $self = shift ;
+# return *$self->{Header};
+#}
+
+sub getExtraParams
+{
+ my $self = shift ;
+ return $self->getZlibParams(),
+}
+
+sub getInverseClass
+{
+ return ('IO::Uncompress::Inflate',
+ \$IO::Uncompress::Inflate::InflateError);
+}
+
+sub getFileInfo
+{
+ my $self = shift ;
+ my $params = shift;
+ my $file = shift ;
+
+}
+
+
1;
$z->seek($position, $whence);
$z->binmode();
$z->fileno();
- $z->newStream();
+ $z->newStream( [OPTS] );
$z->deflateParams();
$z->close() ;
=head1 Functional Interface
-A top-level function, C<deflate>, is provided to carry out "one-shot"
-compression between buffers and/or files. For finer control over the compression process, see the L</"OO Interface"> section.
+A top-level function, C<deflate>, is provided to carry out
+"one-shot" compression between buffers and/or files. For finer
+control over the compression process, see the L</"OO Interface">
+section.
use IO::Compress::Deflate qw(deflate $DeflateError) ;
deflate $input => $output [,OPTS]
or die "deflate failed: $DeflateError\n";
- deflate \%hash [,OPTS]
- or die "deflate failed: $DeflateError\n";
+
The functional interface needs Perl5.005 or better.
=head2 deflate $input => $output [, OPTS]
-If the first parameter is not a hash reference C<deflate> expects
-at least two parameters, C<$input> and C<$output>.
+
+C<deflate> expects at least two parameters, C<$input> and C<$output>.
=head3 The C<$input> parameter
=item An array reference
-If C<$input> is an array reference, the input data will be read from each
-element of the array in turn. The action taken by C<deflate> with
-each element of the array will depend on the type of data stored
-in it. You can mix and match any of the types defined in this list,
-excluding other array or hash references.
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
The complete array will be walked to ensure that it only
-contains valid data types before any data is compressed.
+contains valid filenames before any data is compressed.
+
+
=item An Input FileGlob string
=item A filename
-If the C<$output> parameter is a simple scalar, it is assumed to be a filename.
-This file will be opened for writing and the compressed data will be
-written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
=item A filehandle
-If the C<$output> parameter is a filehandle, the compressed data will
-be written to it.
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output> is a scalar reference, the compressed data will be stored
-in C<$$output>.
-
-
-=item A Hash Reference
-
-If C<$output> is a hash reference, the compressed data will be written
-to C<$output{$input}> as a scalar reference.
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
-When C<$output> is a hash reference, C<$input> must be either a filename or
-list of filenames. Anything else is an error.
=item An Array Reference
-If C<$output> is an array reference, the compressed data will be pushed
-onto the array.
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
=item An Output FileGlob
If the C<$output> parameter is any other type, C<undef> will be returned.
-=head2 deflate \%hash [, OPTS]
-If the first parameter is a hash reference, C<\%hash>, this will be used to
-define both the source of uncompressed data and to control where the
-compressed data is output. Each key/value pair in the hash defines a
-mapping between an input filename, stored in the key, and an output
-file/buffer, stored in the value. Although the input can only be a filename,
-there is more flexibility to control the destination of the compressed
-data. This is determined by the type of the value. Valid types are
-
-=over 5
-
-=item undef
-
-If the value is C<undef> the compressed data will be written to the
-value as a scalar reference.
-
-=item A filename
-
-If the value is a simple scalar, it is assumed to be a filename. This file will
-be opened for writing and the compressed data will be written to it.
-
-=item A filehandle
-
-If the value is a filehandle, the compressed data will be
-written to it.
-The string '-' can be used as an alias for standard output.
-
-
-=item A scalar reference
-
-If the value is a scalar reference, the compressed data will be stored
-in the buffer that is referenced by the scalar.
-
-
-=item A Hash Reference
-
-If the value is a hash reference, the compressed data will be written
-to C<$hash{$input}> as a scalar reference.
-
-=item An Array Reference
-
-If C<$output> is an array reference, the compressed data will be pushed
-onto the array.
-
-=back
-
-Any other type is a error.
=head2 Notes
When C<$input> maps to multiple files/buffers and C<$output> is a single
-file/buffer the compressed input files/buffers will all be stored in
-C<$output> as a single compressed stream.
+file/buffer the compressed input files/buffers will all be stored
+in C<$output> as a single compressed stream.
=item AutoClose =E<gt> 0|1
-This option applies to any input or output data streams to C<deflate>
-that are filehandles.
+This option applies to any input or output data streams to
+C<deflate> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<deflate> has
+=item BinModeIn =E<gt> 0|1
+
+When reading from a file or filehandle, set C<binmode> before reading.
+
+Defaults to 0.
+
+
+
+
+
=item -Append =E<gt> 0|1
TODO
=item -AutoClose =E<gt> 0|1
This option is only valid when the C<$output> parameter is a filehandle. If
-specified, and the value is true, it will result in the C<$output> being closed
-once either the C<close> method is called or the C<IO::Compress::Deflate> object is
-destroyed.
+specified, and the value is true, it will result in the C<$output> being
+closed once either the C<close> method is called or the C<IO::Compress::Deflate>
+object is destroyed.
This parameter defaults to 0.
Opens C<$output> in append mode.
-The behaviour of this option is dependant on the type of C<$output>.
+The behaviour of this option is dependent on the type of C<$output>.
=over 5
=item * A Buffer
-If C<$output> is a buffer and C<Append> is enabled, all compressed data will be
-append to the end if C<$output>. Otherwise C<$output> will be cleared before
-any data is written to it.
+If C<$output> is a buffer and C<Append> is enabled, all compressed data
+will be append to the end if C<$output>. Otherwise C<$output> will be
+cleared before any data is written to it.
=item * A Filename
-If C<$output> is a filename and C<Append> is enabled, the file will be opened
-in append mode. Otherwise the contents of the file, if any, will be truncated
-before any compressed data is written to it.
+If C<$output> is a filename and C<Append> is enabled, the file will be
+opened in append mode. Otherwise the contents of the file, if any, will be
+truncated before any compressed data is written to it.
=item * A Filehandle
-If C<$output> is a filehandle, the file pointer will be positioned to the end
-of the file via a call to C<seek> before any compressed data is written to it.
-Otherwise the file pointer will not be moved.
+If C<$output> is a filehandle, the file pointer will be positioned to the
+end of the file via a call to C<seek> before any compressed data is written
+to it. Otherwise the file pointer will not be moved.
=back
-It is a fatal error to attempt to use this option when C<$output> is not an RFC
-1950 data stream.
+It is a fatal error to attempt to use this option when C<$output> is not an
+RFC 1950 data stream.
=item 1
-This module needs to have been built with zlib 1.2.1 or better to work. A fatal
-error will be thrown if C<Merge> is used with an older version of zlib.
+This module needs to have been built with zlib 1.2.1 or better to work. A
+fatal error will be thrown if C<Merge> is used with an older version of
+zlib.
=item 2
print $z $data
Compresses and outputs the contents of the C<$data> parameter. This
-has the same behavior as the C<print> built-in.
+has the same behaviour as the C<print> built-in.
Returns true if successful.
-=head2 newStream
+=head2 newStream([OPTS])
Usage is
- $z->newStream
+ $z->newStream( [OPTS] )
-TODO
+Closes the current compressed data stream and starts a new one.
+
+OPTS consists of the following sub-set of the the options that are
+available when creating the C<$z> object,
+
+=over 5
+
+=item * Level
+
+=item * TODO
+
+=back
=head2 deflateParams
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
use strict ;
use warnings;
-# create RFC1952
-
-require Exporter ;
-
-our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError);
-
-$VERSION = '2.000_05';
-$GzipError = '' ;
-
-@ISA = qw(Exporter IO::BaseDeflate);
-@EXPORT_OK = qw( $GzipError gzip ) ;
-%EXPORT_TAGS = %IO::BaseDeflate::EXPORT_TAGS ;
-push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
-Exporter::export_ok_tags('all');
-
-sub new
-{
- my $pkg = shift ;
- return IO::BaseDeflate::new($pkg, 'rfc1952', undef, \$GzipError, @_);
-}
-
-
-sub gzip
-{
- return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1952', \$GzipError, @_);
-}
-
-package IO::BaseDeflate;
+use IO::Compress::RawDeflate;
use Compress::Zlib 2 ;
-use Compress::Zlib::Common;
-use Compress::Zlib::FileConstants;
-use Compress::Zlib::ParseParameters;
+use Compress::Zlib::Common qw(:Status createSelfTiedObject);
use Compress::Gzip::Constants;
-use IO::Uncompress::Gunzip;
-
-use IO::File ;
-#use File::Glob;
-require Exporter ;
-use Carp ;
-use Symbol;
-use bytes;
-
-our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS, $got_encode);
-@ISA = qw(Exporter IO::File);
-%EXPORT_TAGS = ( flush => [qw{
- Z_NO_FLUSH
- Z_PARTIAL_FLUSH
- Z_SYNC_FLUSH
- Z_FULL_FLUSH
- Z_FINISH
- Z_BLOCK
- }],
- level => [qw{
- Z_NO_COMPRESSION
- Z_BEST_SPEED
- Z_BEST_COMPRESSION
- Z_DEFAULT_COMPRESSION
- }],
- strategy => [qw{
- Z_FILTERED
- Z_HUFFMAN_ONLY
- Z_RLE
- Z_FIXED
- Z_DEFAULT_STRATEGY
- }],
-
- );
-
-{
- my %seen;
- foreach (keys %EXPORT_TAGS )
- {
- push @{$EXPORT_TAGS{constants}},
- grep { !$seen{$_}++ }
- @{ $EXPORT_TAGS{$_} }
- }
- $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ;
-}
-
-Exporter::export_ok_tags('all');
-
BEGIN
{
else
{ *noUTF8 = sub {} }
}
-
-
-$VERSION = '2.000_03';
-
-#Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16.
-
-#$got_encode = 0;
-#eval
-#{
-# require Encode;
-# Encode->import('encode', 'find_encoding');
-#};
-#
-#$got_encode = 1 unless $@;
-
-sub saveStatus
-{
- my $self = shift ;
- ${ *$self->{ErrorNo} } = shift() + 0 ;
- ${ *$self->{Error} } = '' ;
-
- return ${ *$self->{ErrorNo} } ;
-}
-
-
-sub saveErrorString
-{
- my $self = shift ;
- my $retval = shift ;
- ${ *$self->{Error} } = shift ;
- ${ *$self->{ErrorNo} } = shift() + 0 if @_ ;
-
- return $retval;
-}
-
-sub error
-{
- my $self = shift ;
- return ${ *$self->{Error} } ;
-}
-
-sub errorNo
-{
- my $self = shift ;
- return ${ *$self->{ErrorNo} } ;
-}
-
-sub bitmask($$$$)
-{
- my $into = shift ;
- my $value = shift ;
- my $offset = shift ;
- my $mask = shift ;
-
- return $into | (($value & $mask) << $offset ) ;
-}
-
-sub mkDeflateHdr($$$;$)
-{
- my $method = shift ;
- my $cinfo = shift;
- my $level = shift;
- my $fdict_adler = shift ;
-
- my $cmf = 0;
- my $flg = 0;
- my $fdict = 0;
- $fdict = 1 if defined $fdict_adler;
-
- $cmf = bitmask($cmf, $method, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS);
- $cmf = bitmask($cmf, $cinfo, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS);
-
- $flg = bitmask($flg, $fdict, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS);
- $flg = bitmask($flg, $level, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS);
-
- my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ;
- $flg = bitmask($flg, $fcheck, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS);
-
- my $hdr = pack("CC", $cmf, $flg) ;
- $hdr .= pack("N", $fdict_adler) if $fdict ;
- return $hdr;
-}
-
-sub mkDeflateHeader ($)
-{
- my $param = shift ;
-
- my $level = $param->value('Level');
- my $strategy = $param->value('Strategy');
+require Exporter ;
- my $lflag ;
- $level = 6
- if $level == Z_DEFAULT_COMPRESSION ;
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError);
- if (ZLIB_VERNUM >= 0x1210)
- {
- if ($strategy >= Z_HUFFMAN_ONLY || $level < 2)
- { $lflag = ZLIB_FLG_LEVEL_FASTEST }
- elsif ($level < 6)
- { $lflag = ZLIB_FLG_LEVEL_FAST }
- elsif ($level == 6)
- { $lflag = ZLIB_FLG_LEVEL_DEFAULT }
- else
- { $lflag = ZLIB_FLG_LEVEL_SLOWEST }
- }
- else
- {
- $lflag = ($level - 1) >> 1 ;
- $lflag = 3 if $lflag > 3 ;
- }
+$VERSION = '2.000_07';
+$GzipError = '' ;
- #my $wbits = (MAX_WBITS - 8) << 4 ;
- my $wbits = 7;
- mkDeflateHdr(ZLIB_CMF_CM_DEFLATED, $wbits, $lflag);
-}
+@ISA = qw(Exporter IO::Compress::RawDeflate);
+@EXPORT_OK = qw( $GzipError gzip ) ;
+%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
-sub mkGzipHeader
+sub new
{
- my $param = shift ;
-
- # stort-circuit if a minimal header is requested.
- return GZIP_MINIMUM_HEADER if $param->value('Minimal') ;
-
- # METHOD
- my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ;
-
- # FLAGS
- my $flags = GZIP_FLG_DEFAULT ;
- $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ;
- $flags |= GZIP_FLG_FHCRC if $param->value('HeaderCRC') ;
- $flags |= GZIP_FLG_FEXTRA if $param->wantValue('ExtraField') ;
- $flags |= GZIP_FLG_FNAME if $param->wantValue('Name') ;
- $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ;
-
- # MTIME
- my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ;
-
- # EXTRA FLAGS
- my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT);
-
- # OS CODE
- my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ;
-
-
- my $out = pack("C4 V C C",
- GZIP_ID1, # ID1
- GZIP_ID2, # ID2
- $method, # Compression Method
- $flags, # Flags
- $time, # Modification Time
- $extra_flags, # Extra Flags
- $os_code, # Operating System Code
- ) ;
-
- # EXTRA
- if ($flags & GZIP_FLG_FEXTRA) {
- my $extra = $param->value('ExtraField') ;
- $out .= pack("v", length $extra) . $extra ;
- }
-
- # NAME
- if ($flags & GZIP_FLG_FNAME) {
- my $name .= $param->value('Name') ;
- $name =~ s/\x00.*$//;
- $out .= $name ;
- # Terminate the filename with NULL unless it already is
- $out .= GZIP_NULL_BYTE
- if !length $name or
- substr($name, 1, -1) ne GZIP_NULL_BYTE ;
- }
-
- # COMMENT
- if ($flags & GZIP_FLG_FCOMMENT) {
- my $comment .= $param->value('Comment') ;
- $comment =~ s/\x00.*$//;
- $out .= $comment ;
- # Terminate the comment with NULL unless it already is
- $out .= GZIP_NULL_BYTE
- if ! length $comment or
- substr($comment, 1, -1) ne GZIP_NULL_BYTE;
- }
-
- # HEADER CRC
- $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ;
+ my $class = shift ;
- noUTF8($out);
+ my $obj = createSelfTiedObject($class, \$GzipError);
- return $out ;
+ $obj->_create(undef, @_);
}
-sub ExtraFieldError
-{
- return "Error with ExtraField Parameter: $_[0]" ;
-}
-sub validateExtraFieldPair
+sub gzip
{
- my $pair = shift ;
- my $lax = shift ;
-
- return ExtraFieldError("Not an array ref")
- unless ref $pair && ref $pair eq 'ARRAY';
-
- return ExtraFieldError("SubField must have two parts")
- unless @$pair == 2 ;
-
- return ExtraFieldError("SubField ID is a reference")
- if ref $pair->[0] ;
-
- return ExtraFieldError("SubField Data is a reference")
- if ref $pair->[1] ;
-
- # ID is exactly two chars
- return ExtraFieldError("SubField ID not two chars long")
- unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ;
-
- # Check that the 2nd byte of the ID isn't 0
- return ExtraFieldError("SubField ID 2nd byte is 0x00")
- if ! $lax && substr($pair->[0], 1, 1) eq "\x00" ;
-
- return ExtraFieldError("SubField Data too long")
- if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ;
-
-
- return undef ;
+ my $obj = createSelfTiedObject(undef, \$GzipError);
+ return $obj->_def(@_);
}
-sub parseExtra
-{
- my $data = shift ;
- my $lax = shift ;
-
- return undef
- if $lax ;
-
- my $XLEN = length $data ;
-
- return ExtraFieldError("Too Large")
- if $XLEN > GZIP_FEXTRA_MAX_SIZE;
-
- my $offset = 0 ;
- while ($offset < $XLEN) {
-
- return ExtraFieldError("FEXTRA Body")
- if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
-
- my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
- $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
-
- my $subLen = unpack("v", substr($data, $offset,
- GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
- $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
-
- return ExtraFieldError("FEXTRA Body")
- if $offset + $subLen > $XLEN ;
-
- my $bad = validateExtraFieldPair( [$id,
- substr($data, $offset, $subLen)], $lax );
- return $bad if $bad ;
-
- $offset += $subLen ;
- }
-
- return undef ;
-}
+#sub newHeader
+#{
+# my $self = shift ;
+# #return GZIP_MINIMUM_HEADER ;
+# return $self->mkHeader(*$self->{Got});
+#}
-sub parseExtraField
+sub getExtraParams
{
my $self = shift ;
- my $got = shift ;
- my $lax = shift ;
-
- # ExtraField can be any of
- #
- # -ExtraField => $data
- # -ExtraField => [$id1, $data1,
- # $id2, $data2]
- # ...
- # ]
- # -ExtraField => [ [$id1 => $data1],
- # [$id2 => $data2],
- # ...
- # ]
- # -ExtraField => { $id1 => $data1,
- # $id2 => $data2,
- # ...
- # }
+ use Compress::Zlib::ParseParameters;
- return undef
- unless $got->parsed('ExtraField') ;
-
- return parseExtra($got->value('ExtraField'), $lax)
- unless ref $got->value('ExtraField') ;
-
- my $data = $got->value('ExtraField');
- my $out = '' ;
-
- if (ref $data eq 'ARRAY') {
- if (ref $data->[0]) {
-
- foreach my $pair (@$data) {
- return ExtraFieldError("Not list of lists")
- unless ref $pair eq 'ARRAY' ;
-
- my $bad = validateExtraFieldPair($pair, $lax) ;
- return $bad if $bad ;
-
- $out .= $pair->[0] . pack("v", length $pair->[1]) .
- $pair->[1] ;
- }
- }
- else {
- return ExtraFieldError("Not even number of elements")
- unless @$data % 2 == 0;
-
- for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) {
- my $bad = validateExtraFieldPair([$data->[$ix], $data->[$ix+1]], $lax) ;
- return $bad if $bad ;
-
- $out .= $data->[$ix] . pack("v", length $data->[$ix+1]) .
- $data->[$ix+1] ;
- }
- }
- }
- elsif (ref $data eq 'HASH') {
- while (my ($id, $info) = each %$data) {
- my $bad = validateExtraFieldPair([$id, $info], $lax);
- return $bad if $bad ;
-
- $out .= $id . pack("v", length $info) . $info ;
- }
- }
- else {
- return ExtraFieldError("Not a scalar, array ref or hash ref") ;
- }
-
- $got->value('ExtraField' => $out);
-
- return undef;
-}
-
-sub checkParams
-{
- my $class = shift ;
- my $type = shift ;
-
- my $rfc1952 = ($type eq 'rfc1952');
- my $rfc1950 = ($type eq 'rfc1950');
-
- my $got = Compress::Zlib::ParseParameters::new();
-
- $got->parse(
- $rfc1952 ?
- {
- 'AutoClose'=> [Parse_boolean, 0],
- #'Encoding'=> [Parse_any, undef],
- 'Strict' => [Parse_boolean, 1],
- 'Append' => [Parse_boolean, 0],
- 'Merge' => [Parse_boolean, 0],
- 'BinModeIn' => [Parse_boolean, 0],
-
+ return (
# zlib behaviour
- #'Method' => [Parse_unsigned, Z_DEFLATED],
- 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION],
- 'Strategy' => [Parse_signed, Z_DEFAULT_STRATEGY],
+ $self->getZlibParams(),
# Gzip header fields
- 'Minimal' => [Parse_boolean, 0],
- 'Comment' => [Parse_any, undef],
- 'Name' => [Parse_any, undef],
- 'Time' => [Parse_any, undef],
- 'TextFlag' => [Parse_boolean, 0],
- 'HeaderCRC' => [Parse_boolean, 0],
- 'OS_Code' => [Parse_unsigned, $Compress::Zlib::gzip_os_code],
- 'ExtraField'=> [Parse_string, undef],
- 'ExtraFlags'=> [Parse_any, undef],
- }
- :
- {
- 'AutoClose' => [Parse_boolean, 0],
- #'Encoding' => [Parse_any, undef],
- 'CRC32' => [Parse_boolean, 0],
- 'ADLER32' => [Parse_boolean, 0],
- 'Strict' => [Parse_boolean, 1],
- 'Append' => [Parse_boolean, 0],
- 'Merge' => [Parse_boolean, 0],
- 'BinModeIn' => [Parse_boolean, 0],
-
- # zlib behaviour
- #'Method' => [Parse_unsigned, Z_DEFLATED],
- 'Level' => [Parse_signed, Z_DEFAULT_COMPRESSION],
- 'Strategy' => [Parse_signed, Z_DEFAULT_STRATEGY],
- },
- @_) or croak "${class}: $got->{Error}" ;
-
- return $got ;
+ 'Minimal' => [0, 1, Parse_boolean, 0],
+ 'Comment' => [0, 1, Parse_any, undef],
+ 'Name' => [0, 1, Parse_any, undef],
+ 'Time' => [0, 1, Parse_any, undef],
+ 'TextFlag' => [0, 1, Parse_boolean, 0],
+ 'HeaderCRC' => [0, 1, Parse_boolean, 0],
+ 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Zlib::gzip_os_code],
+ 'ExtraField'=> [0, 1, Parse_string, undef],
+ 'ExtraFlags'=> [0, 1, Parse_any, undef],
+
+ );
}
-sub new
-{
- my $class = shift ;
- my $type = shift ;
- my $got = shift;
- my $error_ref = shift ;
-
- croak("$class: Missing Output parameter")
- if ! @_ && ! $got ;
- my $outValue = shift ;
- my $oneShot = 1 ;
-
- if (! $got)
- {
- $oneShot = 0 ;
- $got = checkParams($class, $type, @_)
- or return undef ;
- }
-
- my $rfc1952 = ($type eq 'rfc1952');
- my $rfc1950 = ($type eq 'rfc1950');
- my $rfc1951 = ($type eq 'rfc1951');
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
- my $obj = bless Symbol::gensym(), ref($class) || $class;
- tie *$obj, $obj if $] >= 5.005;
+ # gzip always needs crc32
+ $got->value('CRC32' => 1);
- *$obj->{Closed} = 1 ;
- $$error_ref = '' ;
- *$obj->{Error} = $error_ref ;
+ return 1
+ if $got->value('Merge') ;
my $lax = ! $got->value('Strict') ;
- my $outType = whatIsOutput($outValue);
-
- ckOutputParam($class, $outValue, $error_ref)
- or return undef ;
-
- if ($outType eq 'buffer') {
- *$obj->{Buffer} = $outValue;
- }
- else {
- my $buff = "" ;
- *$obj->{Buffer} = \$buff ;
- }
-
- # Merge implies Append
- my $merge = $got->value('Merge') ;
- my $appendOutput = $got->value('Append') || $merge ;
- if ($merge)
{
- # Switch off Merge mode if output file/buffer is empty/doesn't exist
- if (($outType eq 'buffer' && length $$outValue == 0 ) ||
- ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) )
- { $merge = 0 }
- }
-
- # If output is a file, check that it is writable
- if ($outType eq 'filename' && -e $outValue && ! -w _)
- { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) }
-
- elsif ($outType eq 'handle' && ! -w $outValue)
- { return $obj->saveErrorString(undef, "Output filehandle is not writable" ) }
-
-
-# TODO - encoding
-# if ($got->parsed('Encoding')) {
-# croak("$class: Encode module needed to use -Encoding")
-# if ! $got_encode;
-#
-# my $want_encoding = $got->value('Encoding');
-# my $encoding = find_encoding($want_encoding);
-#
-# croak("$class: Encoding '$want_encoding' is not available")
-# if ! $encoding;
-#
-# *$obj->{Encoding} = $encoding;
-# }
-
- if ($rfc1952 && ! $merge) {
-
if (! $got->parsed('Time') ) {
# Modification time defaults to now.
$got->value('Time' => time) ;
if ($got->parsed('Name') && defined $got->value('Name')) {
my $name = $got->value('Name');
- return $obj->saveErrorString(undef, "Null Character found in Name",
+ return $self->saveErrorString(undef, "Null Character found in Name",
Z_DATA_ERROR)
if ! $lax && $name =~ /\x00/ ;
- return $obj->saveErrorString(undef, "Non ISO 8859-1 Character found in Name",
+ return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Name",
Z_DATA_ERROR)
if ! $lax && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ;
}
if ($got->parsed('Comment') && defined $got->value('Comment')) {
my $comment = $got->value('Comment');
- return $obj->saveErrorString(undef, "Null Character found in Comment",
+ return $self->saveErrorString(undef, "Null Character found in Comment",
Z_DATA_ERROR)
if ! $lax && $comment =~ /\x00/ ;
- return $obj->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment",
+ return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment",
Z_DATA_ERROR)
if ! $lax && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o;
}
if ($got->parsed('OS_Code') ) {
my $value = $got->value('OS_Code');
- return $obj->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'")
+ return $self->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'")
if $value < 0 || $value > 255 ;
}
if ($got->parsed('ExtraField')) {
- my $bad = $obj->parseExtraField($got, $lax) ;
- return $obj->saveErrorString(undef, $bad, Z_DATA_ERROR)
+ my $bad = $self->parseExtraField($got, $lax) ;
+ return $self->saveErrorString(undef, $bad, Z_DATA_ERROR)
if $bad ;
my $len = length $got->value('ExtraField') ;
- return $obj->saveErrorString(undef, ExtraFieldError("Too Large"),
+ return $self->saveErrorString(undef, ExtraFieldError("Too Large"),
Z_DATA_ERROR)
if $len > GZIP_FEXTRA_MAX_SIZE;
}
}
- $obj->saveStatus(Z_OK) ;
-
- my $end_offset = 0;
- my $status ;
- if (! $merge)
- {
- (*$obj->{Deflate}, $status) = new Compress::Zlib::Deflate
- -AppendOutput => 1,
- -CRC32 => $rfc1952 || $got->value('CRC32'),
- -ADLER32 => $rfc1950 || $got->value('ADLER32'),
- -Level => $got->value('Level'),
- -Strategy => $got->value('Strategy'),
- -WindowBits => - MAX_WBITS;
- return $obj->saveErrorString(undef, "Cannot create Deflate object: $status" )
- if $obj->saveStatus($status) != Z_OK ;
-
- *$obj->{BytesWritten} = 0 ;
- *$obj->{ISize} = 0 ;
-
- *$obj->{Header} = mkDeflateHeader($got)
- if $rfc1950 ;
- *$obj->{Header} = ''
- if $rfc1951 ;
- *$obj->{Header} = mkGzipHeader($got)
- if $rfc1952 ;
-
- if ( $outType eq 'buffer') {
- ${ *$obj->{Buffer} } = ''
- unless $appendOutput ;
- ${ *$obj->{Buffer} } .= *$obj->{Header};
- }
- else {
- if ($outType eq 'handle') {
- $outValue->flush() ;
- *$obj->{FH} = $outValue ;
- setBinModeOutput(*$obj->{FH}) ;
- *$obj->{Handle} = 1 ;
- if ($appendOutput)
- {
- seek(*$obj->{FH}, 0, SEEK_END)
- or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
-
- }
- }
- elsif ($outType eq 'filename') {
- my $mode = '>' ;
- $mode = '>>'
- if $appendOutput;
- *$obj->{FH} = new IO::File "$mode $outValue"
- or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ;
- *$obj->{StdIO} = ($outValue eq '-');
- setBinModeOutput(*$obj->{FH}) ;
- }
-
- if (!$rfc1951) {
- defined *$obj->{FH}->write(*$obj->{Header}, length(*$obj->{Header}))
- or return $obj->saveErrorString(undef, $!, $!) ;
- }
- }
- }
- else
- {
- my %mapping = ( 'rfc1952' => ['IO::Uncompress::Gunzip', \$IO::Uncompress::Gunzip::GunzipError],
- 'rfc1950' => ['IO::Uncompress::Inflate', \$IO::Uncompress::Inflate::InflateError],
- 'rfc1951' => ['IO::Uncompress::RawInflate', \$IO::Uncompress::RawInflate::RawInflateError],
- );
-
- my $inf = IO::BaseInflate::new($mapping{$type}[0],
- $type, undef,
- $error_ref, 0, $outValue,
- Transparent => 0,
- #Strict => 1,
- AutoClose => 0,
- Scan => 1);
-
- return $obj->saveErrorString(undef, "Cannot create InflateScan object: $$error_ref" )
- if ! defined $inf ;
-
- $inf->scan()
- or return $obj->saveErrorString(undef, "Error Scanning: $$error_ref", $inf->errorNo) ;
- $inf->zap($end_offset)
- or return $obj->saveErrorString(undef, "Error Zapping: $$error_ref", $inf->errorNo) ;
-
- (*$obj->{Deflate}, $status) = $inf->createDeflate();
-
- *$obj->{Header} = *$inf->{Info}{Header};
- *$obj->{ISize} =
- *$obj->{ISize} = *$obj->{BytesWritten} = *$inf->{ISize} ;
-
- if ( $outType eq 'buffer')
- { substr( ${ *$obj->{Buffer} }, $end_offset) = '' }
- elsif ($outType eq 'handle' || $outType eq 'filename') {
- *$obj->{FH} = *$inf->{FH} ;
- delete *$inf->{FH};
- *$obj->{FH}->flush() ;
- *$obj->{Handle} = 1 if $outType eq 'handle';
-
- #seek(*$obj->{FH}, $end_offset, SEEK_SET)
- *$obj->{FH}->seek($end_offset, SEEK_SET)
- or return $obj->saveErrorString(undef, $!, $!) ;
- }
- }
-
- *$obj->{Closed} = 0 ;
- *$obj->{AutoClose} = $got->value('AutoClose') ;
- *$obj->{OutputGzip} = $rfc1952;
- *$obj->{OutputDeflate} = $rfc1950;
- *$obj->{OutputRawDeflate} = $rfc1951;
- *$obj->{Output} = $outValue;
- *$obj->{ClassName} = $class;
- *$obj->{Got} = $got;
-
- return $obj ;
-}
-
-sub _def
-{
- my $class = shift ;
- my $type = shift ;
- my $error_ref = shift ;
-
- my $name = (caller(1))[3] ;
-
- croak "$name: expected at least 1 parameters\n"
- unless @_ >= 1 ;
-
- my $input = shift ;
- my $haveOut = @_ ;
- my $output = shift ;
-
- my $x = new Validator($class, $type, $error_ref, $name, $input, $output)
- or return undef ;
-
- push @_, $output if $haveOut && $x->{Hash};
-
- my $got = checkParams($name, $type, @_)
- or return undef ;
-
- $x->{Got} = $got ;
- $x->{ParsedTime} = $got->parsed('Time') ;
- $x->{ParsedName} = $got->parsed('Name') ;
-
- if ($x->{Hash})
- {
- while (my($k, $v) = each %$input)
- {
- $v = \$input->{$k}
- unless defined $v ;
-
- _singleTarget($x, 1, $k, $v, @_)
- or return undef ;
- }
-
- return keys %$input ;
- }
-
- if ($x->{GlobMap})
- {
- $x->{oneInput} = 1 ;
- foreach my $pair (@{ $x->{Pairs} })
- {
- my ($from, $to) = @$pair ;
- _singleTarget($x, 1, $from, $to, @_)
- or return undef ;
- }
-
- return scalar @{ $x->{Pairs} } ;
- }
-
- if (! $x->{oneOutput} )
- {
- my $inFile = ($x->{inType} eq 'filenames'
- || $x->{inType} eq 'filename');
-
- $x->{inType} = $inFile ? 'filename' : 'buffer';
-
- foreach my $in ($x->{oneInput} ? $input : @$input)
- {
- my $out ;
- $x->{oneInput} = 1 ;
-
- _singleTarget($x, $inFile, $in, \$out, @_)
- or return undef ;
-
- if ($x->{outType} eq 'array')
- { push @$output, \$out }
- else
- { $output->{$in} = \$out }
- }
-
- return 1 ;
- }
-
- # finally the 1 to 1 and n to 1
- return _singleTarget($x, 1, $input, $output, @_);
-
- croak "should not be here" ;
-}
-
-sub _singleTarget
-{
- my $x = shift ;
- my $inputIsFilename = shift;
- my $input = shift;
-
-
- # For gzip, if input is simple filename, populate Name & Time in
- # gzip header from filename by default.
- if ($x->{Type} eq 'rfc1952' and isaFilename($input) and $inputIsFilename)
- {
- my $defaultTime = (stat($input))[8] ;
-
- $x->{Got}->value('Name' => $input)
- if ! $x->{ParsedName};
-
- $x->{Got}->value('Time' => $defaultTime)
- if ! $x->{ParsedTime};
- }
-
- my $gzip = new($x->{Class}, $x->{Type}, $x->{Got}, $x->{Error}, @_)
- or return undef ;
-
-
- if ($x->{oneInput})
- {
- defined $gzip->_wr2($input, $inputIsFilename)
- or return undef ;
- }
- else
- {
- my $afterFirst = 0 ;
- my $inputIsFilename = ($x->{inType} ne 'array');
-
- for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
- {
- if ( $afterFirst ++ )
- {
- defined addInterStream($gzip, $x, $element, $inputIsFilename)
- or return undef ;
- }
-
- defined $gzip->_wr2($element, $inputIsFilename)
- or return undef ;
- }
- }
-
- return $gzip->close() ;
+ return 1;
}
-sub _wr2
+sub mkTrailer
{
my $self = shift ;
-
- my $source = shift ;
- my $inputIsFilename = shift;
-
- my $input = $source ;
- if (! $inputIsFilename)
- {
- $input = \$source
- if ! ref $source;
- }
-
- if ( ref $input && ref $input eq 'SCALAR' )
- {
- return $self->syswrite($input, @_) ;
- }
-
- if ( ! ref $input || isaFilehandle($input))
- {
- my $isFilehandle = isaFilehandle($input) ;
-
- my $fh = $input ;
-
- if ( ! $isFilehandle )
- {
- $fh = new IO::File "<$input"
- or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ;
- }
- binmode $fh if *$self->{Got}->valueOrDefault('BinModeIn') ;
-
- my $status ;
- my $buff ;
- my $count = 0 ;
- while (($status = read($fh, $buff, 4096)) > 0) {
- $count += length $buff;
- defined $self->syswrite($buff, @_)
- or return undef ;
- }
-
- return $self->saveErrorString(undef, $!, $!)
- if $status < 0 ;
-
- if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-')
- {
- $fh->close()
- or return undef ;
- }
-
- return $count ;
- }
-
- croak "Should no be here";
- return undef;
-}
-
-sub addInterStream
-{
- my $gzip = shift ;
- my $x = shift ;
- my $input = shift ;
- my $inputIsFilename = shift ;
-
- if ($x->{Got}->value('MultiStream'))
- {
- # For gzip, if input is simple filename, populate Name & Time in
- # gzip header from filename by default.
- if ($x->{Type} eq 'rfc1952' and isaFilename($input) and $inputIsFilename)
- {
- my $defaultTime = (stat($input))[8] ;
-
- $x->{Got}->value('Name' => $input)
- if ! $x->{ParsedName};
-
- $x->{Got}->value('Time' => $defaultTime)
- if ! $x->{ParsedTime};
- }
-
- # TODO -- newStream needs to allow gzip header to be modified
- return $gzip->newStream();
- }
- elsif ($x->{Got}->value('AutoFlush'))
- {
- return $gzip->flush(Z_FULL_FLUSH);
- }
-
- return 1 ;
+ return pack("V V", *$self->{Compress}->crc32(),
+ *$self->{UnCompSize_32bit});
}
-sub TIEHANDLE
+sub getInverseClass
{
- return $_[0] if ref($_[0]);
- die "OOPS\n" ;
-}
-
-sub UNTIE
-{
- my $self = shift ;
+ return ('IO::Uncompress::Gunzip',
+ \$IO::Uncompress::Gunzip::GunzipError);
}
-sub DESTROY
+sub getFileInfo
{
my $self = shift ;
- $self->close() ;
-
- # TODO - memory leak with 5.8.0 - this isn't called until
- # global destruction
- #
- %{ *$self } = () ;
- undef $self ;
-}
+ my $params = shift;
+ my $filename = shift ;
+ my $defaultTime = (stat($filename))[9] ;
-#sub validateInput
-#{
-# my $class = shift ;
-#
-# #local $Carp::CarpLevel = 1;
-#
-# if ( ! ref $_[0] ||
-# ref $_[0] eq 'SCALAR' ||
-# #ref $_[0] eq 'CODE' ||
-# isaFilehandle($_[0]) )
-# {
-# my $inType = whatIs($_[0]);
-# my $outType = whatIs($_[1]);
-#
-# if ($inType eq 'filename' )
-# {
-# croak "$class: input filename is undef or null string"
-# if ! defined $_[0] || $_[0] eq '' ;
-#
-# if ($_[0] ne '-' && ! -e $_[0] )
-# {
-# ${$_[2]} = "input file '$_[0]' does not exist";
-# $_[3] = $!;
-# return undef;
-# }
-#
-# if (! -r $_[0] )
-# {
-# ${$_[2]} = "cannot open file '$_[0]': $!";
-# $_[3] = $!;
-# return undef;
-# }
-# }
-# elsif ($inType eq 'fileglob' )
-# {
-# # whatever...
-# }
-#
-# croak("$class: input and output $inType are identical")
-# if defined $outType && $inType eq $outType && $_[0] eq $_[1] ;
-#
-# return 1 ;
-# }
-#
-# croak "$class: input parameter not a filename, filehandle, array ref or scalar ref"
-# unless ref $_[0] eq 'ARRAY' ;
-#
-# my $array = shift @_ ;
-# foreach my $element ( @{ $array } )
-# {
-# return undef
-# unless validateInput($class, $element, @_);
-# }
-#
-# return 1 ;
-#}
-
+ $params->value('Name' => $filename)
+ if ! $params->parsed('Name') ;
-#sub write
-#{
-# my $self = shift ;
-#
-# if ( isaFilehandle $_[0] )
-# {
-# return $self->_wr(@_);
-# }
-#
-# if ( ref $_[0])
-# {
-# if ( ref $_[0] eq 'SCALAR' )
-# { return $self->syswrite(@_) }
-#
-# if ( ref $_[0] eq 'ARRAY' )
-# {
-# my ($str, $num);
-# validateInput(*$self->{ClassName} . "::write", $_[0], *$self->{Output}, \$str, $num)
-# or return $self->saveErrorString(undef, $str, $num);
-#
-# return $self->_wr(@_);
-# }
-#
-# croak *$self->{ClassName} . "::write: input parameter not a filename, filehandle, array ref or scalar ref";
-# }
-#
-# # Not a reference or a filehandle
-# return $self->syswrite(@_) ;
-#}
-#
-#sub _wr
-#{
-# my $self = shift ;
-#
-# if ( ref $_[0] && ref $_[0] eq 'SCALAR' )
-# {
-# return $self->syswrite(@_) ;
-# }
-#
-# if ( ! ref $_[0] || isaFilehandle($_[0]))
-# {
-# my $item = shift @_ ;
-# my $isFilehandle = isaFilehandle($item) ;
-#
-# my $fh = $item ;
-#
-# if ( ! $isFilehandle )
-# {
-# $fh = new IO::File "<$item"
-# or return $self->saveErrorString(undef, "cannot open file '$item': $!", $!) ;
-# }
-#
-# my $status ;
-# my $buff ;
-# my $count = 0 ;
-# while (($status = read($fh, $buff, 4096)) > 0) {
-# $count += length $buff;
-# defined $self->syswrite($buff, @_)
-# or return undef ;
-# }
-#
-# return $self->saveErrorString(undef, $!, $!)
-# if $status < 0 ;
-#
-#
-# if ( !$isFilehandle || *$self->{AutoClose} )
-# {
-# $fh->close()
-# or return undef ;
-# }
-#
-# return $count ;
-# }
-#
-# #if ref $_[0] eq 'CODE' ;
-#
-# # then must be ARRAY ref
-# my $count = 0 ;
-# my $array = shift @_ ;
-# foreach my $element ( @{ $array } )
-# {
-# my $got = $self->_wr($element, @_) ;
-#
-# return undef
-# unless defined $got ;
-#
-# $count += $got ;
-# }
-#
-# return $count ;
-#}
+ $params->value('Time' => $defaultTime)
+ if ! $params->parsed('Time') ;
+}
-sub syswrite
+sub mkHeader
{
my $self = shift ;
+ my $param = shift ;
- my $buffer ;
- if (ref $_[0] ) {
- croak *$self->{ClassName} . "::write: not a scalar reference"
- unless ref $_[0] eq 'SCALAR' ;
- $buffer = $_[0] ;
- }
- else {
- $buffer = \$_[0] ;
- }
+ # stort-circuit if a minimal header is requested.
+ return GZIP_MINIMUM_HEADER if $param->value('Minimal') ;
- if (@_ > 1) {
- my $slen = defined $$buffer ? length($$buffer) : 0;
- my $len = $slen;
- my $offset = 0;
- $len = $_[1] if $_[1] < $len;
-
- if (@_ > 2) {
- $offset = $_[2] || 0;
- croak *$self->{ClassName} . "::write: offset outside string" if $offset > $slen;
- if ($offset < 0) {
- $offset += $slen;
- croak *$self->{ClassName} . "::write: offset outside string" if $offset < 0;
- }
- my $rem = $slen - $offset;
- $len = $rem if $rem < $len;
- }
+ # METHOD
+ my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ;
- $buffer = \substr($$buffer, $offset, $len) ;
- }
+ # FLAGS
+ my $flags = GZIP_FLG_DEFAULT ;
+ $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ;
+ $flags |= GZIP_FLG_FHCRC if $param->value('HeaderCRC') ;
+ $flags |= GZIP_FLG_FEXTRA if $param->wantValue('ExtraField') ;
+ $flags |= GZIP_FLG_FNAME if $param->wantValue('Name') ;
+ $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ;
+
+ # MTIME
+ my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ;
- my $buffer_length = defined $$buffer ? length($$buffer) : 0 ;
- *$self->{BytesWritten} += $buffer_length ;
- my $rest = GZIP_ISIZE_MAX - *$self->{ISize} ;
- if ($buffer_length > $rest) {
- *$self->{ISize} = $buffer_length - $rest - 1;
- }
- else {
- *$self->{ISize} += $buffer_length ;
- }
+ # EXTRA FLAGS
+ my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT);
-# if (*$self->{Encoding}) {
-# $$buffer = *$self->{Encoding}->encode($$buffer);
-# }
+ # OS CODE
+ my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ;
- #my $length = length $$buffer;
- my $status = *$self->{Deflate}->deflate($buffer, *$self->{Buffer}) ;
- return $self->saveErrorString(undef,"Deflate Error: $status")
- if $self->saveStatus($status) != Z_OK ;
+ my $out = pack("C4 V C C",
+ GZIP_ID1, # ID1
+ GZIP_ID2, # ID2
+ $method, # Compression Method
+ $flags, # Flags
+ $time, # Modification Time
+ $extra_flags, # Extra Flags
+ $os_code, # Operating System Code
+ ) ;
- if ( defined *$self->{FH} and length ${ *$self->{Buffer} }) {
- defined *$self->{FH}->write( ${ *$self->{Buffer} }, length ${ *$self->{Buffer} } )
- or return $self->saveErrorString(undef, $!, $!);
- ${ *$self->{Buffer} } = '' ;
+ # EXTRA
+ if ($flags & GZIP_FLG_FEXTRA) {
+ my $extra = $param->value('ExtraField') ;
+ $out .= pack("v", length $extra) . $extra ;
}
- return $buffer_length;
-}
-
-sub print
-{
- my $self = shift;
-
- #if (ref $self) {
- # $self = *$self{GLOB} ;
- #}
+ # NAME
+ if ($flags & GZIP_FLG_FNAME) {
+ my $name .= $param->value('Name') ;
+ $name =~ s/\x00.*$//;
+ $out .= $name ;
+ # Terminate the filename with NULL unless it already is
+ $out .= GZIP_NULL_BYTE
+ if !length $name or
+ substr($name, 1, -1) ne GZIP_NULL_BYTE ;
+ }
- if (defined $\) {
- if (defined $,) {
- defined $self->syswrite(join($,, @_) . $\);
- } else {
- defined $self->syswrite(join("", @_) . $\);
- }
- } else {
- if (defined $,) {
- defined $self->syswrite(join($,, @_));
- } else {
- defined $self->syswrite(join("", @_));
- }
+ # COMMENT
+ if ($flags & GZIP_FLG_FCOMMENT) {
+ my $comment .= $param->value('Comment') ;
+ $comment =~ s/\x00.*$//;
+ $out .= $comment ;
+ # Terminate the comment with NULL unless it already is
+ $out .= GZIP_NULL_BYTE
+ if ! length $comment or
+ substr($comment, 1, -1) ne GZIP_NULL_BYTE;
}
-}
-sub printf
-{
- my $self = shift;
- my $fmt = shift;
- defined $self->syswrite(sprintf($fmt, @_));
-}
+ # HEADER CRC
+ $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ;
+ noUTF8($out);
+ return $out ;
+}
-sub flush
+sub ExtraFieldError
{
- my $self = shift ;
- my $opt = shift || Z_FINISH ;
- my $status = *$self->{Deflate}->flush(*$self->{Buffer}, $opt) ;
- return $self->saveErrorString(0,"Deflate Error: $status")
- if $self->saveStatus($status) != Z_OK ;
-
- if ( defined *$self->{FH} ) {
- *$self->{FH}->clearerr();
- defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} })
- or return $self->saveErrorString(0, $!, $!);
- ${ *$self->{Buffer} } = '' ;
- }
-
- return 1;
+ return "Error with ExtraField Parameter: $_[0]" ;
}
-sub newStream
+sub validateExtraFieldPair
{
- my $self = shift ;
-
- $self->_writeTrailer(GZIP_MINIMUM_HEADER)
- or return 0 ;
-
- my $status = *$self->{Deflate}->deflateReset() ;
- return $self->saveErrorString(0,"Deflate Error: $status")
- if $self->saveStatus($status) != Z_OK ;
-
- *$self->{BytesWritten} = 0 ;
- *$self->{ISize} = 0 ;
+ my $pair = shift ;
+ my $lax = shift ;
- return 1 ;
-}
+ return ExtraFieldError("Not an array ref")
+ unless ref $pair && ref $pair eq 'ARRAY';
-sub _writeTrailer
-{
- my $self = shift ;
- my $nextHeader = shift || '' ;
+ return ExtraFieldError("SubField must have two parts")
+ unless @$pair == 2 ;
- my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ;
- return $self->saveErrorString(0,"Deflate Error: $status")
- if $self->saveStatus($status) != Z_OK ;
+ return ExtraFieldError("SubField ID is a reference")
+ if ref $pair->[0] ;
- if (*$self->{OutputGzip}) {
- ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(),
- *$self->{ISize} );
- ${ *$self->{Buffer} } .= $nextHeader ;
- }
+ return ExtraFieldError("SubField Data is a reference")
+ if ref $pair->[1] ;
- if (*$self->{OutputDeflate}) {
- ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() );
- ${ *$self->{Buffer} } .= *$self->{Header} ;
- }
+ # ID is exactly two chars
+ return ExtraFieldError("SubField ID not two chars long")
+ unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ;
- return 1 if ! defined *$self->{FH} ;
+ # Check that the 2nd byte of the ID isn't 0
+ return ExtraFieldError("SubField ID 2nd byte is 0x00")
+ if ! $lax && substr($pair->[0], 1, 1) eq "\x00" ;
- defined *$self->{FH}->write(${ *$self->{Buffer} }, length ${ *$self->{Buffer} })
- or return $self->saveErrorString(0, $!, $!);
+ return ExtraFieldError("SubField Data too long")
+ if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ;
- ${ *$self->{Buffer} } = '' ;
- return 1;
+ return undef ;
}
-sub close
+sub parseExtra
{
- my $self = shift ;
-
- return 1 if *$self->{Closed} || ! *$self->{Deflate} ;
- *$self->{Closed} = 1 ;
+ my $data = shift ;
+ my $lax = shift ;
- untie *$self
- if $] >= 5.008 ;
+ return undef
+ if $lax ;
- if (0) {
- $self->_writeTrailer()
- or return 0 ;
- }
- else {
+ my $XLEN = length $data ;
-
- my $status = *$self->{Deflate}->flush(*$self->{Buffer}) ;
- return $self->saveErrorString(0,"Deflate Error: $status")
- if $self->saveStatus($status) != Z_OK ;
+ return ExtraFieldError("Too Large")
+ if $XLEN > GZIP_FEXTRA_MAX_SIZE;
- if (*$self->{OutputGzip}) {
- ${ *$self->{Buffer} } .= pack("V V", *$self->{Deflate}->crc32(),
- *$self->{ISize} );
- }
+ my $offset = 0 ;
+ while ($offset < $XLEN) {
- if (*$self->{OutputDeflate}) {
- ${ *$self->{Buffer} } .= pack("N", *$self->{Deflate}->adler32() );
- }
+ return ExtraFieldError("FEXTRA Body")
+ if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
+ my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
+ $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
- return 1 if ! defined *$self->{FH} ;
+ my $subLen = unpack("v", substr($data, $offset,
+ GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
+ $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
- defined *$self->{FH}->write(${ *$self->{Buffer} }, length( ${ *$self->{Buffer} } ))
- or return $self->saveErrorString(0, $!, $!);
+ return ExtraFieldError("FEXTRA Body")
+ if $offset + $subLen > $XLEN ;
- ${ *$self->{Buffer} } = '' ;
- }
+ my $bad = validateExtraFieldPair( [$id,
+ substr($data, $offset, $subLen)], $lax );
+ return $bad if $bad ;
- if (defined *$self->{FH}) {
- #if (! *$self->{Handle} || *$self->{AutoClose}) {
- if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
- $! = 0 ;
- *$self->{FH}->close()
- or return $self->saveErrorString(0, $!, $!);
- }
- delete *$self->{FH} ;
- # This delete can set $! in older Perls, so reset the errno
- $! = 0 ;
+ $offset += $subLen ;
}
-
- return 1;
+
+ return undef ;
}
-sub deflateParams
+sub parseExtraField
{
my $self = shift ;
- my $level = shift ;
- my $strategy = shift ;
-
- my $status = *$self->{Deflate}->deflateParams(-Level => $level,
- -Strategy => $strategy) ;
- return $self->saveErrorString(0,"deflateParams Error: $status")
- if $self->saveStatus($status) != Z_OK ;
-
- return 1;
-}
-
+ my $got = shift ;
+ my $lax = shift ;
-#sub total_in
-#sub total_out
-#sub msg
-#
-#sub crc
-#{
-# my $self = shift ;
-# return *$self->{Deflate}->crc32() ;
-#}
-#
-#sub msg
-#{
-# my $self = shift ;
-# return *$self->{Deflate}->msg() ;
-#}
-#
-#sub dict_adler
-#{
-# my $self = shift ;
-# return *$self->{Deflate}->dict_adler() ;
-#}
-#
-#sub get_Level
-#{
-# my $self = shift ;
-# return *$self->{Deflate}->get_Level() ;
-#}
-#
-#sub get_Strategy
-#{
-# my $self = shift ;
-# return *$self->{Deflate}->get_Strategy() ;
-#}
+ # ExtraField can be any of
+ #
+ # -ExtraField => $data
+ # -ExtraField => [$id1, $data1,
+ # $id2, $data2]
+ # ...
+ # ]
+ # -ExtraField => [ [$id1 => $data1],
+ # [$id2 => $data2],
+ # ...
+ # ]
+ # -ExtraField => { $id1 => $data1,
+ # $id2 => $data2,
+ # ...
+ # }
+
+ return undef
+ unless $got->parsed('ExtraField') ;
-sub tell
-{
- my $self = shift ;
+ return parseExtra($got->value('ExtraField'), $lax)
+ unless ref $got->value('ExtraField') ;
- #return *$self->{Deflate}->total_in();
- return *$self->{BytesWritten} ;
-}
+ my $data = $got->value('ExtraField');
+ my $out = '' ;
-sub eof
-{
- my $self = shift ;
+ if (ref $data eq 'ARRAY') {
+ if (ref $data->[0]) {
- return *$self->{Closed} ;
-}
+ foreach my $pair (@$data) {
+ return ExtraFieldError("Not list of lists")
+ unless ref $pair eq 'ARRAY' ;
+ my $bad = validateExtraFieldPair($pair, $lax) ;
+ return $bad if $bad ;
-sub seek
-{
- my $self = shift ;
- my $position = shift;
- my $whence = shift ;
+ $out .= $pair->[0] . pack("v", length $pair->[1]) .
+ $pair->[1] ;
+ }
+ }
+ else {
+ return ExtraFieldError("Not even number of elements")
+ unless @$data % 2 == 0;
- my $here = $self->tell() ;
- my $target = 0 ;
+ for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) {
+ my $bad = validateExtraFieldPair([$data->[$ix], $data->[$ix+1]], $lax) ;
+ return $bad if $bad ;
- #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
- use IO::Handle ;
+ $out .= $data->[$ix] . pack("v", length $data->[$ix+1]) .
+ $data->[$ix+1] ;
+ }
+ }
+ }
+ elsif (ref $data eq 'HASH') {
+ while (my ($id, $info) = each %$data) {
+ my $bad = validateExtraFieldPair([$id, $info], $lax);
+ return $bad if $bad ;
- if ($whence == IO::Handle::SEEK_SET) {
- $target = $position ;
- }
- elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) {
- $target = $here + $position ;
- }
+ $out .= $id . pack("v", length $info) . $info ;
+ }
+ }
else {
- croak *$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter";
+ return ExtraFieldError("Not a scalar, array ref or hash ref") ;
}
- # short circuit if seeking to current offset
- return 1 if $target == $here ;
-
- # Outlaw any attempt to seek backwards
- croak *$self->{ClassName} . "::seek: cannot seek backwards"
- if $target < $here ;
-
- # Walk the file to the new offset
- my $offset = $target - $here ;
-
- my $buffer ;
- defined $self->syswrite("\x00" x $offset)
- or return 0;
-
- return 1 ;
-}
-
-sub binmode
-{
- 1;
-# my $self = shift ;
-# return defined *$self->{FH}
-# ? binmode *$self->{FH}
-# : 1 ;
-}
+ $got->value('ExtraField' => $out);
-sub fileno
-{
- my $self = shift ;
- return defined *$self->{FH}
- ? *$self->{FH}->fileno()
- : undef ;
+ return undef;
}
-sub _notAvailable
+sub mkFinalTrailer
{
- my $name = shift ;
- return sub { croak "$name Not Available: File opened only for output" ; } ;
+ return '';
}
-*read = _notAvailable('read');
-*READ = _notAvailable('read');
-*readline = _notAvailable('readline');
-*READLINE = _notAvailable('readline');
-*getc = _notAvailable('getc');
-*GETC = _notAvailable('getc');
-
-*FILENO = \&fileno;
-*PRINT = \&print;
-*PRINTF = \&printf;
-*WRITE = \&syswrite;
-*write = \&syswrite;
-*SEEK = \&seek;
-*TELL = \&tell;
-*EOF = \&eof;
-*CLOSE = \&close;
-*BINMODE = \&binmode;
-
-#*sysread = \&_notAvailable;
-#*syswrite = \&_write;
-
1;
__END__
$z->seek($position, $whence);
$z->binmode();
$z->fileno();
- $z->newStream();
+ $z->newStream( [OPTS] );
$z->deflateParams();
$z->close() ;
=head1 Functional Interface
-A top-level function, C<gzip>, is provided to carry out "one-shot"
-compression between buffers and/or files. For finer control over the compression process, see the L</"OO Interface"> section.
+A top-level function, C<gzip>, is provided to carry out
+"one-shot" compression between buffers and/or files. For finer
+control over the compression process, see the L</"OO Interface">
+section.
use IO::Compress::Gzip qw(gzip $GzipError) ;
gzip $input => $output [,OPTS]
or die "gzip failed: $GzipError\n";
- gzip \%hash [,OPTS]
- or die "gzip failed: $GzipError\n";
+
The functional interface needs Perl5.005 or better.
=head2 gzip $input => $output [, OPTS]
-If the first parameter is not a hash reference C<gzip> expects
-at least two parameters, C<$input> and C<$output>.
+
+C<gzip> expects at least two parameters, C<$input> and C<$output>.
=head3 The C<$input> parameter
=item An array reference
-If C<$input> is an array reference, the input data will be read from each
-element of the array in turn. The action taken by C<gzip> with
-each element of the array will depend on the type of data stored
-in it. You can mix and match any of the types defined in this list,
-excluding other array or hash references.
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
The complete array will be walked to ensure that it only
-contains valid data types before any data is compressed.
+contains valid filenames before any data is compressed.
+
+
=item An Input FileGlob string
from that file -- the NAME gzip header field will be populated with
the filename itself, and the MTIME header field will be set to the
modification time of the file.
-The intention here is to mirror part of the behavior of the gzip
+The intention here is to mirror part of the behaviour of the gzip
executable.
If you do not want to use these defaults they can be overridden by
-explicitly setting the C<Name> and C<Time> options.
+explicitly setting the C<Name> and C<Time> options or by setting the
+C<Minimal> parameter.
=item A filename
-If the C<$output> parameter is a simple scalar, it is assumed to be a filename.
-This file will be opened for writing and the compressed data will be
-written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
=item A filehandle
-If the C<$output> parameter is a filehandle, the compressed data will
-be written to it.
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output> is a scalar reference, the compressed data will be stored
-in C<$$output>.
-
-
-=item A Hash Reference
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
-If C<$output> is a hash reference, the compressed data will be written
-to C<$output{$input}> as a scalar reference.
-
-When C<$output> is a hash reference, C<$input> must be either a filename or
-list of filenames. Anything else is an error.
=item An Array Reference
-If C<$output> is an array reference, the compressed data will be pushed
-onto the array.
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
=item An Output FileGlob
If the C<$output> parameter is any other type, C<undef> will be returned.
-=head2 gzip \%hash [, OPTS]
-
-If the first parameter is a hash reference, C<\%hash>, this will be used to
-define both the source of uncompressed data and to control where the
-compressed data is output. Each key/value pair in the hash defines a
-mapping between an input filename, stored in the key, and an output
-file/buffer, stored in the value. Although the input can only be a filename,
-there is more flexibility to control the destination of the compressed
-data. This is determined by the type of the value. Valid types are
-
-=over 5
-
-=item undef
-
-If the value is C<undef> the compressed data will be written to the
-value as a scalar reference.
-
-=item A filename
-
-If the value is a simple scalar, it is assumed to be a filename. This file will
-be opened for writing and the compressed data will be written to it.
-
-=item A filehandle
-
-If the value is a filehandle, the compressed data will be
-written to it.
-The string '-' can be used as an alias for standard output.
-
-
-=item A scalar reference
-
-If the value is a scalar reference, the compressed data will be stored
-in the buffer that is referenced by the scalar.
-
-
-=item A Hash Reference
-
-If the value is a hash reference, the compressed data will be written
-to C<$hash{$input}> as a scalar reference.
-
-=item An Array Reference
-
-If C<$output> is an array reference, the compressed data will be pushed
-onto the array.
-
-=back
-Any other type is a error.
=head2 Notes
When C<$input> maps to multiple files/buffers and C<$output> is a single
-file/buffer the compressed input files/buffers will all be stored in
-C<$output> as a single compressed stream.
+file/buffer the compressed input files/buffers will all be stored
+in C<$output> as a single compressed stream.
=item AutoClose =E<gt> 0|1
-This option applies to any input or output data streams to C<gzip>
-that are filehandles.
+This option applies to any input or output data streams to
+C<gzip> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<gzip> has
+=item BinModeIn =E<gt> 0|1
+
+When reading from a file or filehandle, set C<binmode> before reading.
+
+Defaults to 0.
+
+
+
+
+
=item -Append =E<gt> 0|1
TODO
=item -AutoClose =E<gt> 0|1
This option is only valid when the C<$output> parameter is a filehandle. If
-specified, and the value is true, it will result in the C<$output> being closed
-once either the C<close> method is called or the C<IO::Compress::Gzip> object is
-destroyed.
+specified, and the value is true, it will result in the C<$output> being
+closed once either the C<close> method is called or the C<IO::Compress::Gzip>
+object is destroyed.
This parameter defaults to 0.
Opens C<$output> in append mode.
-The behaviour of this option is dependant on the type of C<$output>.
+The behaviour of this option is dependent on the type of C<$output>.
=over 5
=item * A Buffer
-If C<$output> is a buffer and C<Append> is enabled, all compressed data will be
-append to the end if C<$output>. Otherwise C<$output> will be cleared before
-any data is written to it.
+If C<$output> is a buffer and C<Append> is enabled, all compressed data
+will be append to the end if C<$output>. Otherwise C<$output> will be
+cleared before any data is written to it.
=item * A Filename
-If C<$output> is a filename and C<Append> is enabled, the file will be opened
-in append mode. Otherwise the contents of the file, if any, will be truncated
-before any compressed data is written to it.
+If C<$output> is a filename and C<Append> is enabled, the file will be
+opened in append mode. Otherwise the contents of the file, if any, will be
+truncated before any compressed data is written to it.
=item * A Filehandle
-If C<$output> is a filehandle, the file pointer will be positioned to the end
-of the file via a call to C<seek> before any compressed data is written to it.
-Otherwise the file pointer will not be moved.
+If C<$output> is a filehandle, the file pointer will be positioned to the
+end of the file via a call to C<seek> before any compressed data is written
+to it. Otherwise the file pointer will not be moved.
=back
-It is a fatal error to attempt to use this option when C<$output> is not an RFC
-1952 data stream.
+It is a fatal error to attempt to use this option when C<$output> is not an
+RFC 1952 data stream.
=item 1
-This module needs to have been built with zlib 1.2.1 or better to work. A fatal
-error will be thrown if C<Merge> is used with an older version of zlib.
+This module needs to have been built with zlib 1.2.1 or better to work. A
+fatal error will be thrown if C<Merge> is used with an older version of
+zlib.
=item 2
-=item -Mimimal =E<gt> 0|1
+=item -Minimal =E<gt> 0|1
If specified, this option will force the creation of the smallest possible
compliant gzip header (which is exactly 10 bytes long) as defined in
=item -TextFlag =E<gt> 0|1
-This parameter controls the setting of the FLG.FTEXT bit in the gzip header. It
-is used to signal that the data stored in the gzip file/buffer is probably
-text.
+This parameter controls the setting of the FLG.FTEXT bit in the gzip
+header. It is used to signal that the data stored in the gzip file/buffer
+is probably text.
The default is 0.
=item -HeaderCRC =E<gt> 0|1
-When true this parameter will set the FLG.FHCRC bit to 1 in the gzip header and
-set the CRC16 header field to the CRC of the complete gzip header except the
-CRC16 field itself.
+When true this parameter will set the FLG.FHCRC bit to 1 in the gzip header
+and set the CRC16 header field to the CRC of the complete gzip header
+except the CRC16 field itself.
-B<Note> that gzip files created with the C<HeaderCRC> flag set to 1 cannot be
-read by most, if not all, of the the standard gunzip utilities, most notably
-gzip version 1.2.4. You should therefore avoid using this option if you want to
-maximise the portability of your gzip files.
+B<Note> that gzip files created with the C<HeaderCRC> flag set to 1 cannot
+be read by most, if not all, of the the standard gunzip utilities, most
+notably gzip version 1.2.4. You should therefore avoid using this option if
+you want to maximize the portability of your gzip files.
This parameter defaults to 0.
=item -OS_Code =E<gt> $value
-Stores C<$value> in the gzip OS header field. A number between 0 and
-255 is valid.
+Stores C<$value> in the gzip OS header field. A number between 0 and 255 is
+valid.
If not specified, this parameter defaults to the OS code of the Operating
System this module was built on. The value 3 is used as a catch-all for all
=item -ExtraField =E<gt> $data
-This parameter allows additional metadata to be stored in the ExtraField in the
-gzip header. An RFC1952 compliant ExtraField consists of zero or more
-subfields. Each subfield consists of a two byte header followed by the subfield
-data.
+This parameter allows additional metadata to be stored in the ExtraField in
+the gzip header. An RFC1952 compliant ExtraField consists of zero or more
+subfields. Each subfield consists of a two byte header followed by the
+subfield data.
The list of subfields can be supplied in any of the following formats
Sets the XFL byte in the gzip header to C<$value>.
-If this option is not present, the value stored in XFL field will be determined
-by the setting of the C<Level> option.
+If this option is not present, the value stored in XFL field will be
+determined by the setting of the C<Level> option.
If C<Level =E<gt> Z_BEST_SPEED> has been specified then XFL is set to 2.
If C<Level =E<gt> Z_BEST_COMPRESSION> has been specified then XFL is set to 4.
This option is enabled by default.
-If C<Strict> is enabled the following behavior will be policed:
+If C<Strict> is enabled the following behaviour will be policed:
=over 5
=back
-When C<Strict> is disabled the following behavior will be policed:
+When C<Strict> is disabled the following behaviour will be policed:
=over 5
print $z $data
Compresses and outputs the contents of the C<$data> parameter. This
-has the same behavior as the C<print> built-in.
+has the same behaviour as the C<print> built-in.
Returns true if successful.
-=head2 newStream
+=head2 newStream([OPTS])
Usage is
- $z->newStream
+ $z->newStream( [OPTS] )
-TODO
+Closes the current compressed data stream and starts a new one.
+
+OPTS consists of the following sub-set of the the options that are
+available when creating the C<$z> object,
+
+=over 5
+
+=item * Level
+
+=item * TODO
+
+=back
=head2 deflateParams
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
#
use strict ;
use warnings;
-use IO::Uncompress::RawInflate;
+
+
+use IO::Compress::Base;
+use CompressPlugin::Deflate ;
require Exporter ;
+use Compress::Zlib::Common qw(:Status createSelfTiedObject);
-our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $RawDeflateError);
-$VERSION = '2.000_05';
+our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError);
+
+$VERSION = '2.000_07';
$RawDeflateError = '';
-@ISA = qw(Exporter IO::BaseDeflate);
+@ISA = qw(Exporter IO::Compress::Base);
@EXPORT_OK = qw( $RawDeflateError rawdeflate ) ;
-%EXPORT_TAGS = %IO::BaseDeflate::EXPORT_TAGS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
-Exporter::export_ok_tags('all');
+%EXPORT_TAGS = ( flush => [qw{
+ Z_NO_FLUSH
+ Z_PARTIAL_FLUSH
+ Z_SYNC_FLUSH
+ Z_FULL_FLUSH
+ Z_FINISH
+ Z_BLOCK
+ }],
+ level => [qw{
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+ }],
+ strategy => [qw{
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+ }],
+
+ );
+
+{
+ my %seen;
+ foreach (keys %EXPORT_TAGS )
+ {
+ push @{$EXPORT_TAGS{constants}},
+ grep { !$seen{$_}++ }
+ @{ $EXPORT_TAGS{$_} }
+ }
+ $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ;
+}
+
+%DEFLATE_CONSTANTS = %EXPORT_TAGS;
+
+Exporter::export_ok_tags('all');
+
sub new
{
- my $pkg = shift ;
- return IO::BaseDeflate::new($pkg, 'rfc1951', undef, \$RawDeflateError, @_);
+ my $class = shift ;
+
+ my $obj = createSelfTiedObject($class, \$RawDeflateError);
+
+ return $obj->_create(undef, @_);
}
sub rawdeflate
{
- return IO::BaseDeflate::_def(__PACKAGE__, 'rfc1951', \$RawDeflateError, @_);
+ my $obj = createSelfTiedObject(undef, \$RawDeflateError);
+ return $obj->_def(@_);
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift;
+
+ return 1 ;
+}
+
+sub mkComp
+{
+ my $self = shift ;
+ my $class = shift ;
+ my $got = shift ;
+
+ #return CompressPlugin::Deflate::mkCompObject($self, $class, $got)
+ my ($obj, $errstr, $errno) = CompressPlugin::Deflate::mkCompObject(
+ $got->value('CRC32'),
+ $got->value('Adler32'),
+ $got->value('Level'),
+ $got->value('Strategy')
+ );
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ return $obj;
+}
+
+
+sub mkHeader
+{
+ my $self = shift ;
+ return '';
+}
+
+sub mkTrailer
+{
+ my $self = shift ;
+ return '';
+}
+
+sub mkFinalTrailer
+{
+ return '';
}
+
+#sub newHeader
+#{
+# my $self = shift ;
+# return '';
+#}
+
+sub getExtraParams
+{
+ my $self = shift ;
+ return $self->getZlibParams();
+}
+
+sub getZlibParams
+{
+ my $self = shift ;
+
+ use Compress::Zlib::ParseParameters;
+ use Compress::Zlib qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY);
+
+
+ return (
+
+ # zlib behaviour
+ #'Method' => [0, 1, Parse_unsigned, Z_DEFLATED],
+ 'Level' => [0, 1, Parse_signed, Z_DEFAULT_COMPRESSION],
+ 'Strategy' => [0, 1, Parse_signed, Z_DEFAULT_STRATEGY],
+
+ 'CRC32' => [0, 1, Parse_boolean, 0],
+ 'ADLER32' => [0, 1, Parse_boolean, 0],
+ 'Merge' => [1, 1, Parse_boolean, 0],
+ );
+
+
+}
+
+sub getInverseClass
+{
+ return ('IO::Uncompress::RawInflate',
+ \$IO::Uncompress::RawInflate::RawInflateError);
+}
+
+sub getFileInfo
+{
+ my $self = shift ;
+ my $params = shift;
+ my $file = shift ;
+
+}
+
+use IO::Seekable qw(SEEK_SET);
+
+sub createMerge
+{
+ my $self = shift ;
+ my $outValue = shift ;
+ my $outType = shift ;
+
+ my ($invClass, $error_ref) = $self->getInverseClass();
+ eval "require $invClass"
+ or die "aaaahhhh" ;
+
+ my $inf = $invClass->new( $outValue,
+ Transparent => 0,
+ #Strict => 1,
+ AutoClose => 0,
+ Scan => 1)
+ or return $self->saveErrorString(undef, "Cannot create InflateScan object: $$error_ref" ) ;
+
+ my $end_offset = 0;
+ $inf->scan()
+ or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $inf->errorNo) ;
+ $inf->zap($end_offset)
+ or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $inf->errorNo) ;
+
+ my $def = *$self->{Compress} = $inf->createDeflate();
+
+ *$self->{Header} = *$inf->{Info}{Header};
+ *$self->{UnCompSize_32bit} =
+ *$self->{BytesWritten} = *$inf->{UnCompSize_32bit} ;
+
+
+ if ( $outType eq 'buffer')
+ { substr( ${ *$self->{Buffer} }, $end_offset) = '' }
+ elsif ($outType eq 'handle' || $outType eq 'filename') {
+ *$self->{FH} = *$inf->{FH} ;
+ delete *$inf->{FH};
+ *$self->{FH}->flush() ;
+ *$self->{Handle} = 1 if $outType eq 'handle';
+
+ #seek(*$self->{FH}, $end_offset, SEEK_SET)
+ *$self->{FH}->seek($end_offset, SEEK_SET)
+ or return $self->saveErrorString(undef, $!, $!) ;
+ }
+
+ return $def ;
+}
+
+#### zlib specific methods
+
+sub deflateParams
+{
+ my $self = shift ;
+
+ my $level = shift ;
+ my $strategy = shift ;
+
+ my $status = *$self->{Compress}->deflateParams(Level => $level, Strategy => $strategy) ;
+ return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo})
+ if $status == STATUS_ERROR;
+
+ return 1;
+}
+
+
+
+
1;
__END__
$z->seek($position, $whence);
$z->binmode();
$z->fileno();
- $z->newStream();
+ $z->newStream( [OPTS] );
$z->deflateParams();
$z->close() ;
=head1 Functional Interface
-A top-level function, C<rawdeflate>, is provided to carry out "one-shot"
-compression between buffers and/or files. For finer control over the compression process, see the L</"OO Interface"> section.
+A top-level function, C<rawdeflate>, is provided to carry out
+"one-shot" compression between buffers and/or files. For finer
+control over the compression process, see the L</"OO Interface">
+section.
use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ;
rawdeflate $input => $output [,OPTS]
or die "rawdeflate failed: $RawDeflateError\n";
- rawdeflate \%hash [,OPTS]
- or die "rawdeflate failed: $RawDeflateError\n";
+
The functional interface needs Perl5.005 or better.
=head2 rawdeflate $input => $output [, OPTS]
-If the first parameter is not a hash reference C<rawdeflate> expects
-at least two parameters, C<$input> and C<$output>.
+
+C<rawdeflate> expects at least two parameters, C<$input> and C<$output>.
=head3 The C<$input> parameter
=item An array reference
-If C<$input> is an array reference, the input data will be read from each
-element of the array in turn. The action taken by C<rawdeflate> with
-each element of the array will depend on the type of data stored
-in it. You can mix and match any of the types defined in this list,
-excluding other array or hash references.
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
The complete array will be walked to ensure that it only
-contains valid data types before any data is compressed.
+contains valid filenames before any data is compressed.
+
+
=item An Input FileGlob string
=item A filename
-If the C<$output> parameter is a simple scalar, it is assumed to be a filename.
-This file will be opened for writing and the compressed data will be
-written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
=item A filehandle
-If the C<$output> parameter is a filehandle, the compressed data will
-be written to it.
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output> is a scalar reference, the compressed data will be stored
-in C<$$output>.
-
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
-=item A Hash Reference
-
-If C<$output> is a hash reference, the compressed data will be written
-to C<$output{$input}> as a scalar reference.
-
-When C<$output> is a hash reference, C<$input> must be either a filename or
-list of filenames. Anything else is an error.
=item An Array Reference
-If C<$output> is an array reference, the compressed data will be pushed
-onto the array.
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
=item An Output FileGlob
If the C<$output> parameter is any other type, C<undef> will be returned.
-=head2 rawdeflate \%hash [, OPTS]
-
-If the first parameter is a hash reference, C<\%hash>, this will be used to
-define both the source of uncompressed data and to control where the
-compressed data is output. Each key/value pair in the hash defines a
-mapping between an input filename, stored in the key, and an output
-file/buffer, stored in the value. Although the input can only be a filename,
-there is more flexibility to control the destination of the compressed
-data. This is determined by the type of the value. Valid types are
-
-=over 5
-
-=item undef
-
-If the value is C<undef> the compressed data will be written to the
-value as a scalar reference.
-
-=item A filename
-
-If the value is a simple scalar, it is assumed to be a filename. This file will
-be opened for writing and the compressed data will be written to it.
-
-=item A filehandle
-
-If the value is a filehandle, the compressed data will be
-written to it.
-The string '-' can be used as an alias for standard output.
-
-
-=item A scalar reference
-
-If the value is a scalar reference, the compressed data will be stored
-in the buffer that is referenced by the scalar.
-
-
-=item A Hash Reference
-
-If the value is a hash reference, the compressed data will be written
-to C<$hash{$input}> as a scalar reference.
-
-=item An Array Reference
-
-If C<$output> is an array reference, the compressed data will be pushed
-onto the array.
-
-=back
-Any other type is a error.
=head2 Notes
When C<$input> maps to multiple files/buffers and C<$output> is a single
-file/buffer the compressed input files/buffers will all be stored in
-C<$output> as a single compressed stream.
+file/buffer the compressed input files/buffers will all be stored
+in C<$output> as a single compressed stream.
=item AutoClose =E<gt> 0|1
-This option applies to any input or output data streams to C<rawdeflate>
-that are filehandles.
+This option applies to any input or output data streams to
+C<rawdeflate> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<rawdeflate> has
+=item BinModeIn =E<gt> 0|1
+
+When reading from a file or filehandle, set C<binmode> before reading.
+
+Defaults to 0.
+
+
+
+
+
=item -Append =E<gt> 0|1
TODO
=item -AutoClose =E<gt> 0|1
This option is only valid when the C<$output> parameter is a filehandle. If
-specified, and the value is true, it will result in the C<$output> being closed
-once either the C<close> method is called or the C<IO::Compress::RawDeflate> object is
-destroyed.
+specified, and the value is true, it will result in the C<$output> being
+closed once either the C<close> method is called or the C<IO::Compress::RawDeflate>
+object is destroyed.
This parameter defaults to 0.
Opens C<$output> in append mode.
-The behaviour of this option is dependant on the type of C<$output>.
+The behaviour of this option is dependent on the type of C<$output>.
=over 5
=item * A Buffer
-If C<$output> is a buffer and C<Append> is enabled, all compressed data will be
-append to the end if C<$output>. Otherwise C<$output> will be cleared before
-any data is written to it.
+If C<$output> is a buffer and C<Append> is enabled, all compressed data
+will be append to the end if C<$output>. Otherwise C<$output> will be
+cleared before any data is written to it.
=item * A Filename
-If C<$output> is a filename and C<Append> is enabled, the file will be opened
-in append mode. Otherwise the contents of the file, if any, will be truncated
-before any compressed data is written to it.
+If C<$output> is a filename and C<Append> is enabled, the file will be
+opened in append mode. Otherwise the contents of the file, if any, will be
+truncated before any compressed data is written to it.
=item * A Filehandle
-If C<$output> is a filehandle, the file pointer will be positioned to the end
-of the file via a call to C<seek> before any compressed data is written to it.
-Otherwise the file pointer will not be moved.
+If C<$output> is a filehandle, the file pointer will be positioned to the
+end of the file via a call to C<seek> before any compressed data is written
+to it. Otherwise the file pointer will not be moved.
=back
-It is a fatal error to attempt to use this option when C<$output> is not an RFC
-1951 data stream.
+It is a fatal error to attempt to use this option when C<$output> is not an
+RFC 1951 data stream.
=item 1
-This module needs to have been built with zlib 1.2.1 or better to work. A fatal
-error will be thrown if C<Merge> is used with an older version of zlib.
+This module needs to have been built with zlib 1.2.1 or better to work. A
+fatal error will be thrown if C<Merge> is used with an older version of
+zlib.
=item 2
print $z $data
Compresses and outputs the contents of the C<$data> parameter. This
-has the same behavior as the C<print> built-in.
+has the same behaviour as the C<print> built-in.
Returns true if successful.
-=head2 newStream
+=head2 newStream([OPTS])
Usage is
- $z->newStream
+ $z->newStream( [OPTS] )
-TODO
+Closes the current compressed data stream and starts a new one.
+
+OPTS consists of the following sub-set of the the options that are
+available when creating the C<$z> object,
+
+=over 5
+
+=item * Level
+
+=item * TODO
+
+=back
=head2 deflateParams
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
--- /dev/null
+package IO::Compress::Zip ;
+
+use strict ;
+use warnings;
+
+use Compress::Zlib::Common qw(createSelfTiedObject);
+use CompressPlugin::Deflate;
+use CompressPlugin::Identity;
+use IO::Compress::RawDeflate;
+
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $ZipError);
+
+$VERSION = '2.000_04';
+$ZipError = '';
+
+@ISA = qw(Exporter IO::Compress::RawDeflate);
+@EXPORT_OK = qw( $ZipError zip ) ;
+%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+
+sub new
+{
+ my $class = shift ;
+
+ my $obj = createSelfTiedObject($class, \$ZipError);
+ $obj->_create(undef, @_);
+}
+
+sub zip
+{
+ my $obj = createSelfTiedObject(undef, \$ZipError);
+ return $obj->_def(@_);
+}
+
+sub mkComp
+{
+ my $self = shift ;
+ my $class = shift ;
+ my $got = shift ;
+
+ my ($obj, $errstr, $errno) ;
+
+ if (*$self->{ZipData}{Store}) {
+ #return CompressPlugin::Deflate::mkCompObject($self, $class, $got)
+ ($obj, $errstr, $errno) = CompressPlugin::Identity::mkCompObject(
+ $got->value('CRC32'),
+ $got->value('Adler32'),
+ $got->value('Level'),
+ $got->value('Strategy')
+ );
+ }
+ else {
+ #return CompressPlugin::Deflate::mkCompObject($self, $class, $got)
+ ($obj, $errstr, $errno) = CompressPlugin::Deflate::mkCompObject(
+ $got->value('CRC32'),
+ $got->value('Adler32'),
+ $got->value('Level'),
+ $got->value('Strategy')
+ );
+ }
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ return $obj;
+}
+
+
+
+sub mkHeader
+{
+ my $self = shift;
+ my $param = shift ;
+
+ my $filename = '';
+ $filename = $param->value('Name') || '';
+
+ my $comment = '';
+ $comment = $param->value('Comment') || '';
+
+ my $extract = $param->value('OS_Code') << 8 + 20 ;
+ my $hdr = '';
+
+ my $time = _unixToDosTime($param->value('Time'));
+ *$self->{ZipData}{StartOffset} = *$self->{ZipData}{Offset} ;
+
+ my $strm = *$self->{ZipData}{Stream} ? 8 : 0 ;
+ my $method = *$self->{ZipData}{Store} ? 0 : 8 ;
+
+ $hdr .= pack "V", 0x04034b50 ; # signature
+ $hdr .= pack 'v', $extract ; # extract Version & OS
+ $hdr .= pack 'v', $strm ; # general purpose flag (set streaming mode)
+ $hdr .= pack 'v', $method ; # compression method (deflate)
+ $hdr .= pack 'V', $time ; # last mod date/time
+ $hdr .= pack 'V', 0 ; # crc32 - 0 when streaming
+ $hdr .= pack 'V', 0 ; # compressed length - 0 when streaming
+ $hdr .= pack 'V', 0 ; # uncompressed length - 0 when streaming
+ $hdr .= pack 'v', length $filename ; # filename length
+ $hdr .= pack 'v', 0 ; # extra length
+
+ $hdr .= $filename ;
+
+
+ my $ctl = '';
+
+ $ctl .= pack "V", 0x02014b50 ; # signature
+ $ctl .= pack 'v', $extract ; # version made by
+ $ctl .= pack 'v', $extract ; # extract Version
+ $ctl .= pack 'v', $strm ; # general purpose flag (streaming mode)
+ $ctl .= pack 'v', $method ; # compression method (deflate)
+ $ctl .= pack 'V', $time ; # last mod date/time
+ $ctl .= pack 'V', 0 ; # crc32
+ $ctl .= pack 'V', 0 ; # compressed length
+ $ctl .= pack 'V', 0 ; # uncompressed length
+ $ctl .= pack 'v', length $filename ; # filename length
+ $ctl .= pack 'v', 0 ; # extra length
+ $ctl .= pack 'v', length $comment ; # file comment length
+ $ctl .= pack 'v', 0 ; # disk number start
+ $ctl .= pack 'v', 0 ; # internal file attributes
+ $ctl .= pack 'V', 0 ; # external file attributes
+ $ctl .= pack 'V', *$self->{ZipData}{Offset} ; # offset to local header
+
+ $ctl .= $filename ;
+ #$ctl .= $extra ;
+ $ctl .= $comment ;
+
+ *$self->{ZipData}{Offset} += length $hdr ;
+
+ *$self->{ZipData}{CentralHeader} = $ctl;
+
+ return $hdr;
+}
+
+sub mkTrailer
+{
+ my $self = shift ;
+
+ my $crc32 = *$self->{Compress}->crc32();
+ my $compressedBytes = *$self->{Compress}->compressedBytes();
+ my $uncompressedBytes = *$self->{Compress}->uncompressedBytes();
+
+ my $data ;
+ $data .= pack "V", $crc32 ; # CRC32
+ $data .= pack "V", $compressedBytes ; # Compressed Size
+ $data .= pack "V", $uncompressedBytes; # Uncompressed Size
+
+ my $hdr = '';
+
+ if (*$self->{ZipData}{Stream}) {
+ $hdr = pack "V", 0x08074b50 ; # signature
+ $hdr .= $data ;
+ }
+ else {
+ $self->writeAt(*$self->{ZipData}{StartOffset} + 14, $data)
+ or return undef;
+ }
+
+ my $ctl = *$self->{ZipData}{CentralHeader} ;
+ substr($ctl, 16, 12) = $data ;
+ #substr($ctl, 16, 4) = pack "V", $crc32 ; # CRC32
+ #substr($ctl, 20, 4) = pack "V", $compressedBytes ; # Compressed Size
+ #substr($ctl, 24, 4) = pack "V", $uncompressedBytes ; # Uncompressed Size
+
+ *$self->{ZipData}{Offset} += length($hdr) + $compressedBytes;
+ push @{ *$self->{ZipData}{CentralDir} }, $ctl ;
+
+ return $hdr;
+}
+
+sub mkFinalTrailer
+{
+ my $self = shift ;
+
+ my $entries = @{ *$self->{ZipData}{CentralDir} };
+ my $cd = join '', @{ *$self->{ZipData}{CentralDir} };
+
+ my $ecd = '';
+ $ecd .= pack "V", 0x06054b50 ; # signature
+ $ecd .= pack 'v', 0 ; # number of disk
+ $ecd .= pack 'v', 0 ; # number if disk with central dir
+ $ecd .= pack 'v', $entries ; # entries in central dir on this disk
+ $ecd .= pack 'v', $entries ; # entries in central dir
+ $ecd .= pack 'V', length $cd ; # size of central dir
+ $ecd .= pack 'V', *$self->{ZipData}{Offset} ; # offset to start central dir
+ $ecd .= pack 'v', 0 ; # zipfile comment length
+ #$ecd .= $comment;
+
+ return $cd . $ecd ;
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift;
+
+ $got->value('CRC32' => 1);
+
+ if (! $got->parsed('Time') ) {
+ # Modification time defaults to now.
+ $got->value('Time' => time) ;
+ }
+
+ *$self->{ZipData}{Stream} = $got->value('Stream');
+ *$self->{ZipData}{Store} = $got->value('Store');
+ *$self->{ZipData}{StartOffset} = *$self->{ZipData}{Offset} = 0;
+
+ return 1 ;
+}
+
+#sub newHeader
+#{
+# my $self = shift ;
+#
+# return $self->mkHeader(*$self->{Got});
+#}
+
+sub getExtraParams
+{
+ my $self = shift ;
+
+ use Compress::Zlib::ParseParameters;
+ use Compress::Zlib qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY);
+
+
+ return (
+ # zlib behaviour
+ $self->getZlibParams(),
+
+ 'Stream' => [1, 1, Parse_boolean, 1],
+ 'Store' => [0, 1, Parse_boolean, 0],
+
+# # Zip header fields
+# 'Minimal' => [0, 1, Parse_boolean, 0],
+ 'Comment' => [0, 1, Parse_any, undef],
+ 'ZipComment'=> [0, 1, Parse_any, undef],
+ 'Name' => [0, 1, Parse_any, undef],
+ 'Time' => [0, 1, Parse_any, undef],
+ 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Zlib::gzip_os_code],
+
+# 'TextFlag' => [0, 1, Parse_boolean, 0],
+# 'ExtraField'=> [0, 1, Parse_string, undef],
+ );
+}
+
+sub getInverseClass
+{
+ return ('IO::Uncompress::Unzip',
+ \$IO::Uncompress::Unzip::UnzipError);
+}
+
+sub getFileInfo
+{
+ my $self = shift ;
+ my $params = shift;
+ my $filename = shift ;
+
+ my $defaultTime = (stat($filename))[9] ;
+
+ $params->value('Name' => $filename)
+ if ! $params->parsed('Name') ;
+
+ $params->value('Time' => $defaultTime)
+ if ! $params->parsed('Time') ;
+
+
+}
+
+# from Archive::Zip
+sub _unixToDosTime # Archive::Zip::Member
+{
+ my $time_t = shift;
+ # TODO - add something to cope with unix time < 1980
+ my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
+ my $dt = 0;
+ $dt += ( $sec >> 1 );
+ $dt += ( $min << 5 );
+ $dt += ( $hour << 11 );
+ $dt += ( $mday << 16 );
+ $dt += ( ( $mon + 1 ) << 21 );
+ $dt += ( ( $year - 80 ) << 25 );
+ return $dt;
+}
+
+1;
+
+__END__
use strict;
use warnings;
+
+use Compress::Zlib::Common qw(createSelfTiedObject);
+
+use UncompressPlugin::Inflate ();
+#use UncompressPlugin::Bunzip2 ();
+
+
+#use IO::Uncompress::Base ;
use IO::Uncompress::Gunzip ;
+use IO::Uncompress::Inflate ;
+use IO::Uncompress::RawInflate ;
+use IO::Uncompress::Unzip ;
+#use IO::Uncompress::Bunzip2 ;
+#use IO::Uncompress::UnLzop ;
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError);
-$VERSION = '2.000_05';
+$VERSION = '2.000_07';
$AnyInflateError = '';
-@ISA = qw(Exporter IO::BaseInflate);
+@ISA = qw( Exporter IO::Uncompress::Base );
@EXPORT_OK = qw( $AnyInflateError anyinflate ) ;
-%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ;
+%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
-
-
# TODO - allow the user to pick a set of the three formats to allow
# or just assume want to auto-detect any of the three formats.
sub new
{
- my $pkg = shift ;
- return IO::BaseInflate::new($pkg, 'any', undef, \$AnyInflateError, 0, @_);
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$AnyInflateError);
+ $obj->_create(undef, 0, @_);
}
sub anyinflate
{
- return IO::BaseInflate::_inf(__PACKAGE__, 'any', \$AnyInflateError, @_) ;
+ my $obj = createSelfTiedObject(undef, \$AnyInflateError);
+ return $obj->_inf(@_) ;
+}
+
+sub getExtraParams
+{
+ return ();
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # any always needs both crc32 and adler32
+ $got->value('CRC32' => 1);
+ $got->value('ADLER32' => 1);
+
+ return 1;
+}
+
+sub mkUncomp
+{
+ my $self = shift ;
+ my $class = shift ;
+ my $got = shift ;
+
+ my ($obj, $errstr, $errno) = UncompressPlugin::Inflate::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ my $magic = $self->ckMagic( qw( RawInflate Inflate Gunzip Unzip ) );
+
+ if ($magic) {
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ return 1;
+ }
+
+ return 0 ;
+}
+
+
+
+sub ckMagic
+{
+ my $self = shift;
+ my @names = @_ ;
+
+ my $keep = ref $self ;
+ for my $class ( map { "IO::Uncompress::$_" } @names)
+ {
+ bless $self => $class;
+ my $magic = $self->ckMagic();
+
+ if ($magic)
+ {
+ #bless $self => $class;
+ return $magic ;
+ }
+
+ $self->pushBack(*$self->{HeaderPending}) ;
+ *$self->{HeaderPending} = '' ;
+ }
+
+ bless $self => $keep;
+ return undef;
}
1 ;
-This module provides a Perl interface that allows the reading of files/buffers
-that conform to RFC's 1950, 1951 and 1952.
+This module provides a Perl interface that allows the reading of
+files/buffers that conform to RFC's 1950, 1951 and 1952.
-The module will auto-detect which, if any, of the three supported compression
-formats is being used.
+The module will auto-detect which, if any, of the three supported
+compression formats is being used.
=head1 Functional Interface
-A top-level function, C<anyinflate>, is provided to carry out "one-shot"
-uncompression between buffers and/or files. For finer control over the uncompression process, see the L</"OO Interface"> section.
+A top-level function, C<anyinflate>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ;
anyinflate $input => $output [,OPTS]
or die "anyinflate failed: $AnyInflateError\n";
- anyinflate \%hash [,OPTS]
- or die "anyinflate failed: $AnyInflateError\n";
+
The functional interface needs Perl5.005 or better.
=head2 anyinflate $input => $output [, OPTS]
-If the first parameter is not a hash reference C<anyinflate> expects
-at least two parameters, C<$input> and C<$output>.
+
+C<anyinflate> expects at least two parameters, C<$input> and C<$output>.
=head3 The C<$input> parameter
=item An array reference
-If C<$input> is an array reference, the input data will be read from each
-element of the array in turn. The action taken by C<anyinflate> with
-each element of the array will depend on the type of data stored
-in it. You can mix and match any of the types defined in this list,
-excluding other array or hash references.
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
The complete array will be walked to ensure that it only
-contains valid data types before any data is uncompressed.
+contains valid filenames before any data is uncompressed.
+
+
=item An Input FileGlob string
=item A filename
-If the C<$output> parameter is a simple scalar, it is assumed to be a filename.
-This file will be opened for writing and the uncompressed data will be
-written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output> parameter is a filehandle, the uncompressed data will
-be written to it.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output> is a scalar reference, the uncompressed data will be stored
-in C<$$output>.
-
-
-=item A Hash Reference
-
-If C<$output> is a hash reference, the uncompressed data will be written
-to C<$output{$input}> as a scalar reference.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
-When C<$output> is a hash reference, C<$input> must be either a filename or
-list of filenames. Anything else is an error.
=item An Array Reference
-If C<$output> is an array reference, the uncompressed data will be pushed
-onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
If the C<$output> parameter is any other type, C<undef> will be returned.
-=head2 anyinflate \%hash [, OPTS]
-If the first parameter is a hash reference, C<\%hash>, this will be used to
-define both the source of compressed data and to control where the
-uncompressed data is output. Each key/value pair in the hash defines a
-mapping between an input filename, stored in the key, and an output
-file/buffer, stored in the value. Although the input can only be a filename,
-there is more flexibility to control the destination of the uncompressed
-data. This is determined by the type of the value. Valid types are
-
-=over 5
-
-=item undef
-
-If the value is C<undef> the uncompressed data will be written to the
-value as a scalar reference.
-
-=item A filename
-
-If the value is a simple scalar, it is assumed to be a filename. This file will
-be opened for writing and the uncompressed data will be written to it.
-
-=item A filehandle
-
-If the value is a filehandle, the uncompressed data will be
-written to it.
-The string '-' can be used as an alias for standard output.
-
-
-=item A scalar reference
-
-If the value is a scalar reference, the uncompressed data will be stored
-in the buffer that is referenced by the scalar.
-
-
-=item A Hash Reference
-
-If the value is a hash reference, the uncompressed data will be written
-to C<$hash{$input}> as a scalar reference.
-
-=item An Array Reference
-
-If C<$output> is an array reference, the uncompressed data will be pushed
-onto the array.
-
-=back
-
-Any other type is a error.
=head2 Notes
When C<$input> maps to multiple files/buffers and C<$output> is a single
-file/buffer the uncompressed input files/buffers will all be stored in
-C<$output> as a single uncompressed stream.
+file/buffer the uncompressed input files/buffers will all be stored
+in C<$output> as a single uncompressed stream.
=item AutoClose =E<gt> 0|1
-This option applies to any input or output data streams to C<anyinflate>
-that are filehandles.
+This option applies to any input or output data streams to
+C<anyinflate> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<anyinflate> has
+=item BinModeOut =E<gt> 0|1
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+
+
+
+
=item -Append =E<gt> 0|1
TODO
+=item -MultiStream =E<gt> 0|1
+
+Creates a new stream after each file.
+
+Defaults to 1.
+
=back
Returns an C<IO::Uncompress::AnyInflate> object on success and undef on failure.
The variable C<$AnyInflateError> will contain an error message on failure.
-If you are running Perl 5.005 or better the object, C<$z>, returned from
-IO::Uncompress::AnyInflate can be used exactly like an L<IO::File|IO::File> filehandle.
-This means that all normal input file operations can be carried out with C<$z>.
-For example, to read a line from a compressed file/buffer you can use either
-of these forms
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::AnyInflate can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
$line = $z->getline();
$line = <$z>;
This option can be useful when the compressed data is embedded in another
file/data structure and it is not possible to work out where the compressed
-data begins without having to read the first few bytes. If this is the case,
-the uncompression can be I<primed> with these bytes using this option.
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
=item -Transparent =E<gt> 0|1
=item -BlockSize =E<gt> $num
-When reading the compressed input data, IO::Uncompress::AnyInflate will read it in blocks
-of C<$num> bytes.
+When reading the compressed input data, IO::Uncompress::AnyInflate will read it in
+blocks of C<$num> bytes.
This option defaults to 4096.
=item -InputLength =E<gt> $size
-When present this option will limit the number of compressed bytes read from
-the input file/buffer to C<$size>. This option can be used in the situation
-where there is useful data directly after the compressed data stream and you
-know beforehand the exact length of the compressed data stream.
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
-This option is mostly used when reading from a filehandle, in which case the
-file pointer will be left pointing to the first byte directly after the
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
compressed data stream.
This option controls what the C<read> method does with uncompressed data.
-If set to 1, all uncompressed data will be appended to the output parameter of
-the C<read> method.
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
-If set to 0, the contents of the output parameter of the C<read> method will be
-overwritten by the uncompressed data.
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
Defaults to 0.
This option controls whether the extra checks defined below are used when
-carrying out the decompression. When Strict is on, the extra tests are carried
-out, when Strict is off they are not.
+carrying out the decompression. When Strict is on, the extra tests are
+carried out, when Strict is off they are not.
The default for this option is off.
=item 3
-If the gzip header contains a comment field (FCOMMENT) it consists solely of
-ISO 8859-1 characters plus line-feed.
+If the gzip header contains a comment field (FCOMMENT) it consists solely
+of ISO 8859-1 characters plus line-feed.
=item 4
=item 7
-The value of the ISIZE fields read must match the length of the uncompressed
-data actually read from the file.
+The value of the ISIZE fields read must match the length of the
+uncompressed data actually read from the file.
=back
Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
-writes any uncompressed data into C<$buffer>. If the C<Append> parameter is set
-in the constructor, the uncompressed data will be appended to the C<$buffer>
-parameter. Otherwise C<$buffer> will be overwritten.
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
-Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or
-a negative number on error.
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
=head2 read
Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
-The main difference between this form of the C<read> method and the previous
-one, is that this one will attempt to return I<exactly> C<$length> bytes. The
-only circumstances that this function will not is if end-of-file or an IO error
-is encountered.
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
-Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or
-a negative number on error.
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
=head2 getline
Usage is
- $hdr = $z->getHeaderInfo()
-
-TODO
-
-
-
-
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
--- /dev/null
+package IO::Uncompress::AnyUncompress ;
+
+use strict;
+use warnings;
+
+use Compress::Zlib::Common qw(createSelfTiedObject);
+
+#use IO::Uncompress::Base ;
+use IO::Uncompress::Gunzip ;
+use IO::Uncompress::Inflate ;
+use IO::Uncompress::RawInflate ;
+use IO::Uncompress::Unzip ;
+
+BEGIN
+{
+ eval { require UncompressPlugin::Bunzip2; import UncompressPlugin::Bunzip2 };
+ eval { require UncompressPlugin::LZO; import UncompressPlugin::LZO };
+ eval { require IO::Uncompress::Bunzip2; import IO::Uncompress::Bunzip2 };
+ eval { require IO::Uncompress::UnLzop; import IO::Uncompress::UnLzop };
+}
+
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError);
+
+$VERSION = '2.000_05';
+$AnyUncompressError = '';
+
+@ISA = qw( Exporter IO::Uncompress::Base );
+@EXPORT_OK = qw( $AnyUncompressError anyuncompress ) ;
+%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+# TODO - allow the user to pick a set of the three formats to allow
+# or just assume want to auto-detect any of the three formats.
+
+sub new
+{
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$AnyUncompressError);
+ $obj->_create(undef, 0, @_);
+}
+
+sub anyuncompress
+{
+ my $obj = createSelfTiedObject(undef, \$AnyUncompressError);
+ return $obj->_inf(@_) ;
+}
+
+sub getExtraParams
+{
+ return ();
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # any always needs both crc32 and adler32
+ $got->value('CRC32' => 1);
+ $got->value('ADLER32' => 1);
+
+ return 1;
+}
+
+sub mkUncomp
+{
+ my $self = shift ;
+ my $class = shift ;
+ my $got = shift ;
+
+ # try zlib first
+ my ($obj, $errstr, $errno) = UncompressPlugin::Inflate::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ my $magic = $self->ckMagic( qw( RawInflate Inflate Gunzip Unzip ) );
+
+ if ($magic) {
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ return 1;
+ }
+
+ #foreach my $type ( qw( Bunzip2 UnLzop ) ) {
+ if (defined $IO::Uncompress::Bunzip2::VERSION and
+ $magic = $self->ckMagic('Bunzip2')) {
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ my ($obj, $errstr, $errno) = UncompressPlugin::Bunzip2::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ return 1;
+ }
+ elsif (defined $IO::Uncompress::UnLzop::VERSION and
+ $magic = $self->ckMagic('UnLzop')) {
+
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ my ($obj, $errstr, $errno) = UncompressPlugin::LZO::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ return 1;
+ }
+
+ return 0 ;
+}
+
+
+
+sub ckMagic
+{
+ my $self = shift;
+ my @names = @_ ;
+
+ my $keep = ref $self ;
+ for my $class ( map { "IO::Uncompress::$_" } @names)
+ {
+ bless $self => $class;
+ my $magic = $self->ckMagic();
+
+ if ($magic)
+ {
+ #bless $self => $class;
+ return $magic ;
+ }
+
+ $self->pushBack(*$self->{HeaderPending}) ;
+ *$self->{HeaderPending} = '' ;
+ }
+
+ bless $self => $keep;
+ return undef;
+}
+
+1 ;
+
+__END__
+
+
--- /dev/null
+
+package IO::Uncompress::Base ;
+
+use strict ;
+use warnings;
+use bytes;
+
+our ($VERSION, @EXPORT_OK, %EXPORT_TAGS);
+
+$VERSION = '2.000_05';
+
+use constant G_EOF => 0 ;
+use constant G_ERR => -1 ;
+
+use Compress::Zlib::Common ;
+use Compress::Zlib::ParseParameters ;
+
+use IO::File ;
+use Symbol;
+use Scalar::Util qw(readonly);
+use List::Util qw(min);
+use Carp ;
+
+%EXPORT_TAGS = ( );
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+#Exporter::export_ok_tags('all') ;
+
+
+sub smartRead
+{
+ my $self = $_[0];
+ my $out = $_[1];
+ my $size = $_[2];
+ $$out = "" ;
+
+ my $offset = 0 ;
+
+
+ if ( length *$self->{Prime} ) {
+ #$$out = substr(*$self->{Prime}, 0, $size, '') ;
+ $$out = substr(*$self->{Prime}, 0, $size) ;
+ substr(*$self->{Prime}, 0, $size) = '' ;
+ if (length $$out == $size) {
+ #*$self->{InputLengthRemaining} -= length $$out;
+ return length $$out ;
+ }
+ $offset = length $$out ;
+ }
+
+ my $get_size = $size - $offset ;
+
+ if ( defined *$self->{InputLength} ) {
+ #*$self->{InputLengthRemaining} += length *$self->{Prime} ;
+ #*$self->{InputLengthRemaining} = *$self->{InputLength}
+ # if *$self->{InputLengthRemaining} > *$self->{InputLength};
+ $get_size = min($get_size, *$self->{InputLengthRemaining});
+ }
+
+ if (defined *$self->{FH})
+ { *$self->{FH}->read($$out, $get_size, $offset) }
+ elsif (defined *$self->{InputEvent}) {
+ my $got = 1 ;
+ while (length $$out < $size) {
+ last
+ if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0;
+ }
+
+ if (length $$out > $size ) {
+ #*$self->{Prime} = substr($$out, $size, length($$out), '');
+ *$self->{Prime} = substr($$out, $size, length($$out));
+ substr($$out, $size, length($$out)) = '';
+ }
+
+ *$self->{EventEof} = 1 if $got <= 0 ;
+ }
+ else {
+ no warnings 'uninitialized';
+ my $buf = *$self->{Buffer} ;
+ $$buf = '' unless defined $$buf ;
+ #$$out = '' unless defined $$out ;
+ substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size);
+ *$self->{BufferOffset} += length($$out) - $offset ;
+ }
+
+ *$self->{InputLengthRemaining} -= length $$out;
+
+ $self->saveStatus(length $$out < 0 ? STATUS_ERROR : 0) ;
+
+ return length $$out;
+}
+
+sub pushBack
+{
+ my $self = shift ;
+
+ return if ! defined $_[0] || length $_[0] == 0 ;
+
+ if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
+ *$self->{Prime} = $_[0] . *$self->{Prime} ;
+ }
+ else {
+ my $len = length $_[0];
+
+ if($len > *$self->{BufferOffset}) {
+ *$self->{Prime} = substr($_[0], 0, $len - *$self->{BufferOffset}) . *$self->{Prime} ;
+ *$self->{InputLengthRemaining} = *$self->{InputLength};
+ *$self->{BufferOffset} = 0
+ }
+ else {
+ *$self->{InputLengthRemaining} += length($_[0]);
+ *$self->{BufferOffset} -= length($_[0]) ;
+ }
+ }
+}
+
+sub smartSeek
+{
+ my $self = shift ;
+ my $offset = shift ;
+ my $truncate = shift;
+ #print "smartSeek to $offset\n";
+
+ # TODO -- need to take prime into account
+ if (defined *$self->{FH})
+ { *$self->{FH}->seek($offset, SEEK_SET) }
+ else {
+ *$self->{BufferOffset} = $offset ;
+ substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = ''
+ if $truncate;
+ return 1;
+ }
+}
+
+sub smartWrite
+{
+ my $self = shift ;
+ my $out_data = shift ;
+
+ if (defined *$self->{FH}) {
+ # flush needed for 5.8.0
+ defined *$self->{FH}->write($out_data, length $out_data) &&
+ defined *$self->{FH}->flush() ;
+ }
+ else {
+ my $buf = *$self->{Buffer} ;
+ substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ;
+ *$self->{BufferOffset} += length($out_data) ;
+ return 1;
+ }
+}
+
+sub smartReadExact
+{
+ return $_[0]->smartRead($_[1], $_[2]) == $_[2];
+}
+
+sub smartEof
+{
+ my ($self) = $_[0];
+
+ return 0 if length *$self->{Prime};
+
+ if (defined *$self->{FH})
+ { *$self->{FH}->eof() }
+ elsif (defined *$self->{InputEvent})
+ { *$self->{EventEof} }
+ else
+ { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) }
+}
+
+sub clearError
+{
+ my $self = shift ;
+
+ *$self->{ErrorNo} = 0 ;
+ ${ *$self->{Error} } = '' ;
+}
+
+sub saveStatus
+{
+ my $self = shift ;
+ my $errno = shift() + 0 ;
+ #return $errno unless $errno || ! defined *$self->{ErrorNo};
+ #return $errno unless $errno ;
+
+ *$self->{ErrorNo} = $errno;
+ ${ *$self->{Error} } = '' ;
+
+ return *$self->{ErrorNo} ;
+}
+
+
+sub saveErrorString
+{
+ my $self = shift ;
+ my $retval = shift ;
+
+ #return $retval if ${ *$self->{Error} };
+
+ ${ *$self->{Error} } = shift ;
+ *$self->{ErrorNo} = shift() + 0 if @_ ;
+
+ #warn "saveErrorString: " . ${ *$self->{Error} } . " " . *$self->{Error} . "\n" ;
+ return $retval;
+}
+
+sub croakError
+{
+ my $self = shift ;
+ $self->saveErrorString(0, $_[0]);
+ croak $_[0];
+}
+
+
+sub closeError
+{
+ my $self = shift ;
+ my $retval = shift ;
+
+ my $errno = *$self->{ErrorNo};
+ my $error = ${ *$self->{Error} };
+
+ $self->close();
+
+ *$self->{ErrorNo} = $errno ;
+ ${ *$self->{Error} } = $error ;
+
+ return $retval;
+}
+
+sub error
+{
+ my $self = shift ;
+ return ${ *$self->{Error} } ;
+}
+
+sub errorNo
+{
+ my $self = shift ;
+ return *$self->{ErrorNo};
+}
+
+sub HeaderError
+{
+ my ($self) = shift;
+ return $self->saveErrorString(undef, "Header Error: $_[0]", STATUS_ERROR);
+}
+
+sub TrailerError
+{
+ my ($self) = shift;
+ return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", STATUS_ERROR);
+}
+
+sub TruncatedHeader
+{
+ my ($self) = shift;
+ return $self->HeaderError("Truncated in $_[0] Section");
+}
+
+sub checkParams
+{
+ my $self = shift ;
+ my $class = shift ;
+
+ my $got = shift || Compress::Zlib::ParseParameters::new();
+
+ my $Valid = {
+ 'BlockSize' => [1, 1, Parse_unsigned, 16 * 1024],
+ 'AutoClose' => [1, 1, Parse_boolean, 0],
+ 'Strict' => [1, 1, Parse_boolean, 0],
+ #'Lax' => [1, 1, Parse_boolean, 1],
+ 'Append' => [1, 1, Parse_boolean, 0],
+ 'Prime' => [1, 1, Parse_any, undef],
+ 'MultiStream' => [1, 1, Parse_boolean, 0],
+ 'Transparent' => [1, 1, Parse_any, 1],
+ 'Scan' => [1, 1, Parse_boolean, 0],
+ 'InputLength' => [1, 1, Parse_unsigned, undef],
+ 'BinModeOut' => [1, 1, Parse_boolean, 0],
+
+ $self->getExtraParams(),
+
+
+ #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0,
+ # ContinueAfterEof
+ } ;
+
+
+ $got->parse($Valid, @_ )
+ or $self->croakError("${class}: $got->{Error}") ;
+
+
+ return $got;
+}
+
+sub _create
+{
+ my $obj = shift;
+ my $got = shift;
+ my $append_mode = shift ;
+
+ my $class = ref $obj;
+ $obj->croakError("$class: Missing Input parameter")
+ if ! @_ && ! $got ;
+
+ my $inValue = shift ;
+
+ if (! $got)
+ {
+ $got = $obj->checkParams($class, undef, @_)
+ or return undef ;
+ }
+
+ my $inType = whatIsInput($inValue, 1);
+
+ $obj->ckInputParam($class, $inValue, 1)
+ or return undef ;
+
+ *$obj->{InNew} = 1;
+
+ $obj->ckParams($got)
+ or $obj->croakError("${class}: $obj->{Error}");
+
+ if ($inType eq 'buffer' || $inType eq 'code') {
+ *$obj->{Buffer} = $inValue ;
+ *$obj->{InputEvent} = $inValue
+ if $inType eq 'code' ;
+ }
+ else {
+ if ($inType eq 'handle') {
+ *$obj->{FH} = $inValue ;
+ *$obj->{Handle} = 1 ;
+ # Need to rewind for Scan
+ #seek(*$obj->{FH}, 0, SEEK_SET) if $got->value('Scan');
+ *$obj->{FH}->seek(0, SEEK_SET) if $got->value('Scan');
+ }
+ else {
+ my $mode = '<';
+ $mode = '+<' if $got->value('Scan');
+ *$obj->{StdIO} = ($inValue eq '-');
+ *$obj->{FH} = new IO::File "$mode $inValue"
+ or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ;
+ *$obj->{LineNo} = 0;
+ }
+
+ setBinModeInput(*$obj->{FH}) ;
+
+ my $buff = "" ;
+ *$obj->{Buffer} = \$buff ;
+ }
+
+
+ *$obj->{InputLength} = $got->parsed('InputLength')
+ ? $got->value('InputLength')
+ : undef ;
+ *$obj->{InputLengthRemaining} = $got->value('InputLength');
+ *$obj->{BufferOffset} = 0 ;
+ *$obj->{AutoClose} = $got->value('AutoClose');
+ *$obj->{Strict} = $got->value('Strict');
+ #*$obj->{Strict} = ! $got->value('Lax');
+ *$obj->{BlockSize} = $got->value('BlockSize');
+ *$obj->{Append} = $got->value('Append');
+ *$obj->{AppendOutput} = $append_mode || $got->value('Append');
+ *$obj->{Transparent} = $got->value('Transparent');
+ *$obj->{MultiStream} = $got->value('MultiStream');
+
+ # TODO - move these two into RawDeflate
+ *$obj->{Scan} = $got->value('Scan');
+ *$obj->{ParseExtra} = $got->value('ParseExtra')
+ || $got->value('Strict') ;
+ #|| ! $got->value('Lax') ;
+ *$obj->{Type} = '';
+ *$obj->{Prime} = $got->value('Prime') || '' ;
+ *$obj->{Pending} = '';
+ *$obj->{Plain} = 0;
+ *$obj->{PlainBytesRead} = 0;
+ *$obj->{InflatedBytesRead} = 0;
+ *$obj->{UnCompSize_32bit} = 0;
+ *$obj->{TotalInflatedBytesRead} = 0;
+ *$obj->{NewStream} = 0 ;
+ *$obj->{EventEof} = 0 ;
+ *$obj->{ClassName} = $class ;
+ *$obj->{Params} = $got ;
+
+ my $status = $obj->mkUncomp($class, $got);
+
+ return undef
+ unless defined $status;
+
+ if ( ! $status) {
+ return undef
+ unless *$obj->{Transparent};
+
+ $obj->clearError();
+ *$obj->{Type} = 'plain';
+ *$obj->{Plain} = 1;
+ #$status = $obj->mkIdentityUncomp($class, $got);
+ $obj->pushBack(*$obj->{HeaderPending}) ;
+ }
+
+ push @{ *$obj->{InfoList} }, *$obj->{Info} ;
+
+ $obj->saveStatus(0) ;
+ *$obj->{InNew} = 0;
+ *$obj->{Closed} = 0;
+
+ return $obj;
+}
+
+sub ckInputParam
+{
+ my $self = shift ;
+ my $from = shift ;
+ my $inType = whatIsInput($_[0], $_[1]);
+
+ $self->croakError("$from: input parameter not a filename, filehandle, array ref or scalar ref")
+ if ! $inType ;
+
+ if ($inType eq 'filename' )
+ {
+ $self->croakError("$from: input filename is undef or null string")
+ if ! defined $_[0] || $_[0] eq '' ;
+
+ if ($_[0] ne '-' && ! -e $_[0] )
+ {
+ return $self->saveErrorString(undef,
+ "input file '$_[0]' does not exist", STATUS_ERROR);
+ }
+ }
+
+ return 1;
+}
+
+
+sub _inf
+{
+ my $obj = shift ;
+
+ my $class = (caller)[0] ;
+ my $name = (caller(1))[3] ;
+
+ $obj->croakError("$name: expected at least 1 parameters\n")
+ unless @_ >= 1 ;
+
+ my $input = shift ;
+ my $haveOut = @_ ;
+ my $output = shift ;
+
+
+ my $x = new Validator($class, *$obj->{Error}, $name, $input, $output)
+ or return undef ;
+
+ push @_, $output if $haveOut && $x->{Hash};
+
+ my $got = $obj->checkParams($name, undef, @_)
+ or return undef ;
+
+ $x->{Got} = $got ;
+
+ if ($x->{Hash})
+ {
+ while (my($k, $v) = each %$input)
+ {
+ $v = \$input->{$k}
+ unless defined $v ;
+
+ $obj->_singleTarget($x, 1, $k, $v, @_)
+ or return undef ;
+ }
+
+ return keys %$input ;
+ }
+
+ if ($x->{GlobMap})
+ {
+ $x->{oneInput} = 1 ;
+ foreach my $pair (@{ $x->{Pairs} })
+ {
+ my ($from, $to) = @$pair ;
+ $obj->_singleTarget($x, 1, $from, $to, @_)
+ or return undef ;
+ }
+
+ return scalar @{ $x->{Pairs} } ;
+ }
+
+ #if ($x->{outType} eq 'array' || $x->{outType} eq 'hash')
+ if (! $x->{oneOutput} )
+ {
+ my $inFile = ($x->{inType} eq 'filenames'
+ || $x->{inType} eq 'filename');
+
+ $x->{inType} = $inFile ? 'filename' : 'buffer';
+ my $ot = $x->{outType} ;
+ $x->{outType} = 'buffer';
+
+ foreach my $in ($x->{oneInput} ? $input : @$input)
+ {
+ my $out ;
+ $x->{oneInput} = 1 ;
+
+ $obj->_singleTarget($x, $inFile, $in, \$out, @_)
+ or return undef ;
+
+ if ($ot eq 'array')
+ { push @$output, \$out }
+ else
+ { $output->{$in} = \$out }
+ }
+
+ return 1 ;
+ }
+
+ # finally the 1 to 1 and n to 1
+ return $obj->_singleTarget($x, 1, $input, $output, @_);
+
+ croak "should not be here" ;
+}
+
+sub retErr
+{
+ my $x = shift ;
+ my $string = shift ;
+
+ ${ $x->{Error} } = $string ;
+
+ return undef ;
+}
+
+sub _singleTarget
+{
+ my $self = shift ;
+ my $x = shift ;
+ my $inputIsFilename = shift;
+ my $input = shift;
+ my $output = shift;
+
+ $x->{buff} = '' ;
+
+ my $fh ;
+ if ($x->{outType} eq 'filename') {
+ my $mode = '>' ;
+ $mode = '>>'
+ if $x->{Got}->value('Append') ;
+ $x->{fh} = new IO::File "$mode $output"
+ or return retErr($x, "cannot open file '$output': $!") ;
+ binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
+
+ }
+
+ elsif ($x->{outType} eq 'handle') {
+ $x->{fh} = $output;
+ binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
+ if ($x->{Got}->value('Append')) {
+ seek($x->{fh}, 0, SEEK_END)
+ or return retErr($x, "Cannot seek to end of output filehandle: $!") ;
+ }
+ }
+
+
+ elsif ($x->{outType} eq 'buffer' )
+ {
+ $$output = ''
+ unless $x->{Got}->value('Append');
+ $x->{buff} = $output ;
+ }
+
+ if ($x->{oneInput})
+ {
+ defined $self->_rd2($x, $input, $inputIsFilename)
+ or return undef;
+ }
+ else
+ {
+ my $inputIsFilename = ($x->{inType} ne 'array');
+
+ for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
+ {
+ defined $self->_rd2($x, $element, $inputIsFilename)
+ or return undef ;
+ }
+ }
+
+
+ if ( ($x->{outType} eq 'filename' && $output ne '-') ||
+ ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) {
+ $x->{fh}->close()
+ or return retErr($x, $!);
+ #or return $gunzip->saveErrorString(undef, $!, $!);
+ delete $x->{fh};
+ }
+
+ return 1 ;
+}
+
+sub _rd2
+{
+ my $self = shift ;
+ my $x = shift ;
+ my $input = shift;
+ my $inputIsFilename = shift;
+
+ my $z = createSelfTiedObject($x->{Class}, *$self->{Error});
+
+ $z->_create($x->{Got}, 1, $input, @_)
+ or return undef ;
+
+ my $status ;
+ my $fh = $x->{fh};
+
+ while (($status = $z->read($x->{buff})) > 0) {
+ if ($fh) {
+ print $fh $x->{buff}
+ or return $z->saveErrorString(undef, "Error writing to output file: $!", $!);
+ $x->{buff} = '' ;
+ }
+ }
+
+ return $z->closeError(undef)
+ if $status < 0 ;
+
+ $z->close()
+ or return undef ;
+
+ return 1 ;
+}
+
+sub TIEHANDLE
+{
+ return $_[0] if ref($_[0]);
+ die "OOPS\n" ;
+
+}
+
+sub UNTIE
+{
+ my $self = shift ;
+}
+
+
+sub getHeaderInfo
+{
+ my $self = shift ;
+ wantarray ? @{ *$self->{InfoList} } : *$self->{Info};
+}
+
+sub readBlock
+{
+ my $self = shift ;
+ my $buff = shift ;
+ my $size = shift ;
+
+ if (defined *$self->{CompressedInputLength}) {
+ if (*$self->{CompressedInputLengthRemaining} == 0) {
+ delete *$self->{CompressedInputLength};
+ #$$buff = '';
+ return STATUS_OK ;
+ }
+ $size = min($size, *$self->{CompressedInputLengthRemaining} );
+ *$self->{CompressedInputLengthRemaining} -= $size ;
+ }
+
+ my $status = $self->smartRead($buff, $size) ;
+ return $self->saveErrorString(STATUS_ERROR, "Error Reading Data")
+ if $status < 0 ;
+
+ if ($status == 0 ) {
+ *$self->{Closed} = 1 ;
+ *$self->{EndStream} = 1 ;
+ return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR);
+ }
+
+ return STATUS_OK;
+
+}
+
+sub postBlockChk
+{
+ return STATUS_OK;
+}
+
+sub _raw_read
+{
+ # return codes
+ # >0 - ok, number of bytes read
+ # =0 - ok, eof
+ # <0 - not ok
+
+ my $self = shift ;
+
+ return G_EOF if *$self->{Closed} ;
+ #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
+ return G_EOF if *$self->{EndStream} ;
+
+ my $buffer = shift ;
+ my $scan_mode = shift ;
+
+ if (*$self->{Plain}) {
+ my $tmp_buff ;
+ my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ;
+
+ return $self->saveErrorString(G_ERR, "Error reading data: $!", $!)
+ if $len < 0 ;
+
+ if ($len == 0 ) {
+ *$self->{EndStream} = 1 ;
+ }
+ else {
+ *$self->{PlainBytesRead} += $len ;
+ $$buffer .= $tmp_buff;
+ }
+
+ return $len ;
+ }
+
+ if (*$self->{NewStream}) {
+
+ *$self->{NewStream} = 0 ;
+ *$self->{EndStream} = 0 ;
+ *$self->{Uncomp}->reset();
+
+ return G_ERR
+ unless my $magic = $self->ckMagic();
+ *$self->{Info} = $self->readHeader($magic);
+
+ return G_ERR unless defined *$self->{Info} ;
+
+ push @{ *$self->{InfoList} }, *$self->{Info} ;
+
+ # For the headers that actually uncompressed data, put the
+ # uncompressed data into the output buffer.
+ $$buffer .= *$self->{Pending} ;
+ my $len = length *$self->{Pending} ;
+ *$self->{Pending} = '';
+ return $len;
+ }
+
+ my $temp_buf ;
+ my $outSize = 0;
+ my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ;
+ return G_ERR
+ if $status == STATUS_ERROR ;
+
+ my $buf_len = 0;
+ if ($status == STATUS_OK) {
+ my $before_len = defined $$buffer ? length $$buffer : 0 ;
+ $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer,
+ (defined *$self->{CompressedInputLength} &&
+ *$self->{CompressedInputLengthRemaining} <= 0) ||
+ $self->smartEof(), $outSize);
+
+ return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo})
+ if $self->saveStatus($status) == STATUS_ERROR;
+
+ $self->postBlockChk($buffer) == STATUS_OK
+ or return G_ERR;
+
+ #$buf_len = *$self->{Uncomp}->count();
+ $buf_len = length($$buffer) - $before_len;
+
+
+ *$self->{InflatedBytesRead} += $buf_len ;
+ *$self->{TotalInflatedBytesRead} += $buf_len ;
+ my $rest = 0xFFFFFFFF - *$self->{UnCompSize_32bit} ;
+ if ($buf_len > $rest) {
+ *$self->{UnCompSize_32bit} = $buf_len - $rest - 1;
+ }
+ else {
+ *$self->{UnCompSize_32bit} += $buf_len ;
+ }
+ }
+
+ if ($status == STATUS_ENDSTREAM) {
+
+ *$self->{EndStream} = 1 ;
+ $self->pushBack($temp_buf) ;
+ $temp_buf = '';
+
+ my $trailer;
+ if (*$self->{Info}{TrailerLength})
+ {
+ my $trailer_size = *$self->{Info}{TrailerLength} ;
+
+ my $got = $self->smartRead(\$trailer, $trailer_size) ;
+ if ($got != $trailer_size) {
+ return $self->TrailerError("trailer truncated. Expected " .
+ "$trailer_size bytes, got $got")
+ if *$self->{Strict};
+ $self->pushBack($trailer) ;
+ }
+ }
+
+ $self->chkTrailer($trailer) == G_ERR
+ and return G_ERR;
+
+ if (*$self->{MultiStream} && ! $self->smartEof()) {
+ #&& (length $temp_buf || ! $self->smartEof())){
+ *$self->{NewStream} = 1 ;
+ *$self->{EndStream} = 0 ;
+ return $buf_len ;
+ }
+
+ }
+
+
+ # return the number of uncompressed bytes read
+ return $buf_len ;
+}
+
+#sub isEndStream
+#{
+# my $self = shift ;
+# return *$self->{NewStream} ||
+# *$self->{EndStream} ;
+#}
+
+sub streamCount
+{
+ my $self = shift ;
+ return 1 if ! defined *$self->{InfoList};
+ return scalar @{ *$self->{InfoList} } ;
+}
+
+sub read
+{
+ # return codes
+ # >0 - ok, number of bytes read
+ # =0 - ok, eof
+ # <0 - not ok
+
+ my $self = shift ;
+
+ return G_EOF if *$self->{Closed} ;
+ return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
+
+ my $buffer ;
+
+ #$self->croakError(*$self->{ClassName} .
+ # "::read: buffer parameter is read-only")
+ # if Compress::Zlib::_readonly_ref($_[0]);
+
+ if (ref $_[0] ) {
+ $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
+ if readonly(${ $_[0] });
+
+ $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" )
+ unless ref $_[0] eq 'SCALAR' ;
+ $buffer = $_[0] ;
+ }
+ else {
+ $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
+ if readonly($_[0]);
+
+ $buffer = \$_[0] ;
+ }
+
+ my $length = $_[1] ;
+ my $offset = $_[2] || 0;
+
+ # the core read will return 0 if asked for 0 bytes
+ return 0 if defined $length && $length == 0 ;
+
+ $length = $length || 0;
+
+ $self->croakError(*$self->{ClassName} . "::read: length parameter is negative")
+ if $length < 0 ;
+
+ $$buffer = '' unless *$self->{AppendOutput} || $offset ;
+
+ # Short-circuit if this is a simple read, with no length
+ # or offset specified.
+ unless ( $length || $offset) {
+ if (length *$self->{Pending}) {
+ $$buffer .= *$self->{Pending} ;
+ my $len = length *$self->{Pending};
+ *$self->{Pending} = '' ;
+ return $len ;
+ }
+ else {
+ my $len = 0;
+ $len = $self->_raw_read($buffer)
+ while ! *$self->{EndStream} && $len == 0 ;
+ return $len ;
+ }
+ }
+
+ # Need to jump through more hoops - either length or offset
+ # or both are specified.
+ my $out_buffer = \*$self->{Pending} ;
+
+ while (! *$self->{EndStream} && length($$out_buffer) < $length)
+ {
+ my $buf_len = $self->_raw_read($out_buffer);
+ return $buf_len
+ if $buf_len < 0 ;
+ }
+
+ $length = length $$out_buffer
+ if length($$out_buffer) < $length ;
+
+ if ($offset) {
+ $$buffer .= "\x00" x ($offset - length($$buffer))
+ if $offset > length($$buffer) ;
+ #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ;
+ substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ;
+ substr($$out_buffer, 0, $length) = '' ;
+ }
+ else {
+ #$$buffer .= substr($$out_buffer, 0, $length, '') ;
+ $$buffer .= substr($$out_buffer, 0, $length) ;
+ substr($$out_buffer, 0, $length) = '' ;
+ }
+
+ return $length ;
+}
+
+sub _getline
+{
+ my $self = shift ;
+
+ # Slurp Mode
+ if ( ! defined $/ ) {
+ my $data ;
+ 1 while $self->read($data) > 0 ;
+ return \$data ;
+ }
+
+ # Paragraph Mode
+ if ( ! length $/ ) {
+ my $paragraph ;
+ while ($self->read($paragraph) > 0 ) {
+ if ($paragraph =~ s/^(.*?\n\n+)//s) {
+ *$self->{Pending} = $paragraph ;
+ my $par = $1 ;
+ return \$par ;
+ }
+ }
+ return \$paragraph;
+ }
+
+ # Line Mode
+ {
+ my $line ;
+ my $endl = quotemeta($/); # quote in case $/ contains RE meta chars
+ while ($self->read($line) > 0 ) {
+ if ($line =~ s/^(.*?$endl)//s) {
+ *$self->{Pending} = $line ;
+ $. = ++ *$self->{LineNo} ;
+ my $l = $1 ;
+ return \$l ;
+ }
+ }
+ $. = ++ *$self->{LineNo} if defined($line);
+ return \$line;
+ }
+}
+
+sub getline
+{
+ my $self = shift;
+ my $current_append = *$self->{AppendOutput} ;
+ *$self->{AppendOutput} = 1;
+ my $lineref = $self->_getline();
+ *$self->{AppendOutput} = $current_append;
+ return $$lineref ;
+}
+
+sub getlines
+{
+ my $self = shift;
+ $self->croakError(*$self->{ClassName} .
+ "::getlines: called in scalar context\n") unless wantarray;
+ my($line, @lines);
+ push(@lines, $line) while defined($line = $self->getline);
+ return @lines;
+}
+
+sub READLINE
+{
+ goto &getlines if wantarray;
+ goto &getline;
+}
+
+sub getc
+{
+ my $self = shift;
+ my $buf;
+ return $buf if $self->read($buf, 1);
+ return undef;
+}
+
+sub ungetc
+{
+ my $self = shift;
+ *$self->{Pending} = "" unless defined *$self->{Pending} ;
+ *$self->{Pending} = $_[0] . *$self->{Pending} ;
+}
+
+
+sub trailingData
+{
+ my $self = shift ;
+ #return \"" if ! defined *$self->{Trailing} ;
+ #return \*$self->{Trailing} ;
+
+ if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
+ return *$self->{Prime} ;
+ }
+ else {
+ my $buf = *$self->{Buffer} ;
+ my $offset = *$self->{BufferOffset} ;
+ return substr($$buf, $offset, -1) ;
+ }
+}
+
+
+sub eof
+{
+ my $self = shift ;
+
+ return (*$self->{Closed} ||
+ (!length *$self->{Pending}
+ && ( $self->smartEof() || *$self->{EndStream}))) ;
+}
+
+sub tell
+{
+ my $self = shift ;
+
+ my $in ;
+ if (*$self->{Plain}) {
+ $in = *$self->{PlainBytesRead} ;
+ }
+ else {
+ $in = *$self->{TotalInflatedBytesRead} ;
+ }
+
+ my $pending = length *$self->{Pending} ;
+
+ return 0 if $pending > $in ;
+ return $in - $pending ;
+}
+
+sub close
+{
+ # todo - what to do if close is called before the end of the gzip file
+ # do we remember any trailing data?
+ my $self = shift ;
+
+ return 1 if *$self->{Closed} ;
+
+ untie *$self
+ if $] >= 5.008 ;
+
+ my $status = 1 ;
+
+ if (defined *$self->{FH}) {
+ if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
+ #if ( *$self->{AutoClose}) {
+ $! = 0 ;
+ $status = *$self->{FH}->close();
+ return $self->saveErrorString(0, $!, $!)
+ if !*$self->{InNew} && $self->saveStatus($!) != 0 ;
+ }
+ delete *$self->{FH} ;
+ $! = 0 ;
+ }
+ *$self->{Closed} = 1 ;
+
+ return 1;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->close() ;
+}
+
+sub seek
+{
+ my $self = shift ;
+ my $position = shift;
+ my $whence = shift ;
+
+ my $here = $self->tell() ;
+ my $target = 0 ;
+
+
+ if ($whence == SEEK_SET) {
+ $target = $position ;
+ }
+ elsif ($whence == SEEK_CUR) {
+ $target = $here + $position ;
+ }
+ elsif ($whence == SEEK_END) {
+ $target = $position ;
+ $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ;
+ }
+ else {
+ $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter");
+ }
+
+ # short circuit if seeking to current offset
+ return 1 if $target == $here ;
+
+ # Outlaw any attempt to seek backwards
+ $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards")
+ if $target < $here ;
+
+ # Walk the file to the new offset
+ my $offset = $target - $here ;
+
+ my $buffer ;
+ $self->read($buffer, $offset) == $offset
+ or return 0 ;
+
+ return 1 ;
+}
+
+sub fileno
+{
+ my $self = shift ;
+ return defined *$self->{FH}
+ ? fileno *$self->{FH}
+ : undef ;
+}
+
+sub binmode
+{
+ 1;
+# my $self = shift ;
+# return defined *$self->{FH}
+# ? binmode *$self->{FH}
+# : 1 ;
+}
+
+*BINMODE = \&binmode;
+*SEEK = \&seek;
+*READ = \&read;
+*sysread = \&read;
+*TELL = \&tell;
+*EOF = \&eof;
+
+*FILENO = \&fileno;
+*CLOSE = \&close;
+
+sub _notAvailable
+{
+ my $name = shift ;
+ #return sub { croak "$name Not Available" ; } ;
+ return sub { croak "$name Not Available: File opened only for intput" ; } ;
+}
+
+
+*print = _notAvailable('print');
+*PRINT = _notAvailable('print');
+*printf = _notAvailable('printf');
+*PRINTF = _notAvailable('printf');
+*write = _notAvailable('write');
+*WRITE = _notAvailable('write');
+
+#*sysread = \&read;
+#*syswrite = \&_notAvailable;
+
+#package IO::_infScan ;
+#
+#*_raw_read = \&IO::Uncompress::Base::_raw_read ;
+#*smartRead = \&IO::Uncompress::Base::smartRead ;
+#*smartWrite = \&IO::Uncompress::Base::smartWrite ;
+#*smartSeek = \&IO::Uncompress::Base::smartSeek ;
+
+#sub mkIdentityUncomp
+#{
+# my $self = shift ;
+# my $class = shift ;
+# my $got = shift ;
+#
+# *$self->{Uncomp} = UncompressPlugin::Identity::mkUncompObject($self, $class, $got)
+# or return undef;
+#
+# return 1;
+#
+#}
+#
+#
+#package UncompressPlugin::Identity;
+#
+#use strict ;
+#use warnings;
+#
+#our ($VERSION, @ISA, @EXPORT);
+#
+#$VERSION = '2.000_05';
+#
+#use constant STATUS_OK => 0;
+#use constant STATUS_ENDSTREAM => 1;
+#use constant STATUS_ERROR => 2;
+#
+#sub mkUncompObject
+#{
+# my $class = shift ;
+#
+# bless { 'CompSize' => 0,
+# 'UnCompSize' => 0,
+# 'CRC32' => 0,
+# 'ADLER32' => 0,
+# }, __PACKAGE__ ;
+#}
+#
+#sub uncompr
+#{
+# my $self = shift ;
+# my $from = shift ;
+# my $to = shift ;
+# my $eof = shift ;
+#
+#
+# $self->{CompSize} += length $$from ;
+# $self->{UnCompSize} = $self->{CompSize} ;
+#
+# $$to = $$from ;
+#
+# return STATUS_ENDSTREAM if $eof;
+# return STATUS_OK ;
+#}
+#
+#sub count
+#{
+# my $self = shift ;
+# return $self->{UnCompSize} ;
+#}
+#
+#sub sync
+#{
+# return STATUS_OK ;
+#}
+#
+#
+#sub reset
+#{
+# return STATUS_OK ;
+#}
+
+
+package IO::Uncompress::Base ;
+
+
+1 ;
+__END__
+
use strict ;
use warnings;
+use IO::Uncompress::RawInflate ;
+
+use Compress::Zlib qw( crc32 ) ;
+use Compress::Zlib::Common qw(createSelfTiedObject);
+use Compress::Gzip::Constants;
+
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GunzipError);
-@ISA = qw(Exporter IO::BaseInflate);
+@ISA = qw( Exporter IO::Uncompress::RawInflate );
@EXPORT_OK = qw( $GunzipError gunzip );
-%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ;
+%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
-
$GunzipError = '';
-$VERSION = '2.000_05';
-
-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],
- 'BinModeOut' => [Parse_boolean, 0],
- #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0,
- # ContinueAfterEof
- } ;
-
- $Valid->{'ParseExtra'} = [Parse_boolean, 0]
- if $type eq 'rfc1952' ;
-
- my $got = Compress::Zlib::ParseParameters::new();
-
- $got->parse($Valid, @_ )
- or croak "$class: $got->{Error}" ;
-
- return $got;
-}
-
-sub new
-{
- my $class = shift ;
- my $type = shift ;
- my $got = shift;
- my $error_ref = shift ;
- my $append_mode = shift ;
-
- croak("$class: Missing Input parameter")
- if ! @_ && ! $got ;
-
- my $inValue = shift ;
-
- if (! $got)
- {
- $got = checkParams($class, $type, @_)
- or return undef ;
- }
-
- my $inType = whatIsInput($inValue, 1);
-
- ckInputParam($class, $inValue, $error_ref, 1)
- or return undef ;
-
- my $obj = bless Symbol::gensym(), ref($class) || $class;
- tie *$obj, $obj if $] >= 5.005;
-
-
- $$error_ref = '' ;
- *$obj->{Error} = $error_ref ;
- *$obj->{InNew} = 1;
-
- if ($inType eq 'buffer' || $inType eq 'code') {
- *$obj->{Buffer} = $inValue ;
- *$obj->{InputEvent} = $inValue
- if $inType eq 'code' ;
- }
- else {
- if ($inType eq 'handle') {
- *$obj->{FH} = $inValue ;
- *$obj->{Handle} = 1 ;
- # Need to rewind for Scan
- #seek(*$obj->{FH}, 0, SEEK_SET) if $got->value('Scan');
- *$obj->{FH}->seek(0, SEEK_SET) if $got->value('Scan');
- }
- else {
- my $mode = '<';
- $mode = '+<' if $got->value('Scan');
- *$obj->{StdIO} = ($inValue eq '-');
- *$obj->{FH} = new IO::File "$mode $inValue"
- or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ;
- *$obj->{LineNo} = 0;
- }
-
- setBinModeInput(*$obj->{FH}) ;
-
- my $buff = "" ;
- *$obj->{Buffer} = \$buff ;
- }
-
-
- *$obj->{InputLength} = $got->parsed('InputLength')
- ? $got->value('InputLength')
- : undef ;
- *$obj->{InputLengthRemaining} = $got->value('InputLength');
- *$obj->{BufferOffset} = 0 ;
- *$obj->{AutoClose} = $got->value('AutoClose');
- *$obj->{Strict} = $got->value('Strict');
- #*$obj->{Strict} = ! $got->value('Lax');
- *$obj->{BlockSize} = $got->value('BlockSize');
- *$obj->{Append} = $got->value('Append');
- *$obj->{AppendOutput} = $append_mode || $got->value('Append');
- *$obj->{Transparent} = $got->value('Transparent');
- *$obj->{MultiStream} = $got->value('MultiStream');
- *$obj->{Scan} = $got->value('Scan');
- *$obj->{ParseExtra} = $got->value('ParseExtra')
- || $got->value('Strict') ;
- #|| ! $got->value('Lax') ;
- *$obj->{Type} = $type;
- *$obj->{Prime} = $got->value('Prime') || '' ;
- *$obj->{Pending} = '';
- *$obj->{Plain} = 0;
- *$obj->{PlainBytesRead} = 0;
- *$obj->{InflatedBytesRead} = 0;
- *$obj->{ISize} = 0;
- *$obj->{TotalInflatedBytesRead} = 0;
- *$obj->{NewStream} = 0 ;
- *$obj->{EventEof} = 0 ;
- *$obj->{ClassName} = $class ;
-
- my $status;
-
- if (*$obj->{Scan})
- {
- (*$obj->{Inflate}, $status) = new Compress::Zlib::InflateScan
- -CRC32 => $type eq 'rfc1952' ||
- $type eq 'any',
- -ADLER32 => $type eq 'rfc1950' ||
- $type eq 'any',
- -WindowBits => - MAX_WBITS ;
- }
- else
- {
- (*$obj->{Inflate}, $status) = new Compress::Zlib::Inflate
- -AppendOutput => 1,
- -CRC32 => $type eq 'rfc1952' ||
- $type eq 'any',
- -ADLER32 => $type eq 'rfc1950' ||
- $type eq 'any',
- -WindowBits => - MAX_WBITS ;
- }
-
- return $obj->saveErrorString(undef, "Could not create Inflation object: $status")
- if $obj->saveStatus($status) != Z_OK ;
-
- if ($type eq 'rfc1952')
- {
- *$obj->{Info} = $obj->_readFullGzipHeader() ;
- }
- elsif ($type eq 'zip')
- {
- *$obj->{Info} = $obj->_readFullZipHeader() ;
- }
- elsif ($type eq 'rfc1950')
- {
- *$obj->{Info} = $obj->_readDeflateHeader() ;
- }
- elsif ($type eq 'rfc1951')
- {
- *$obj->{Info} = $obj->_isRaw() ;
- }
- elsif ($type eq 'any')
- {
- *$obj->{Info} = $obj->_guessCompression() ;
- }
-
- if (! defined *$obj->{Info})
- {
- return undef unless *$obj->{Transparent};
-
- *$obj->{Type} = 'plain';
- *$obj->{Plain} = 1;
- *$obj->{PlainBytesRead} = length *$obj->{HeaderPending} ;
- }
-
- push @{ *$obj->{InfoList} }, *$obj->{Info} ;
- *$obj->{Pending} = *$obj->{HeaderPending}
- if *$obj->{Plain} || *$obj->{Type} eq 'rfc1951';
-
- $obj->saveStatus(0) ;
- *$obj->{InNew} = 0;
-
- return $obj;
-}
-
-#sub _inf
-#{
-# my $class = shift ;
-# my $type = shift ;
-# my $error_ref = shift ;
-#
-# my $name = (caller(1))[3] ;
-#
-# croak "$name: expected at least 2 parameters\n"
-# unless @_ >= 2 ;
-#
-# my $input = shift ;
-# my $output = shift ;
-#
-# ckInOutParams($name, $input, $output, $error_ref)
-# or return undef ;
-#
-# my $outType = whatIs($output);
-#
-# my $gunzip = new($class, $type, $error_ref, 1, $input, @_)
-# or return undef ;
-#
-# my $fh ;
-# if ($outType eq 'filename') {
-# my $mode = '>' ;
-# $mode = '>>'
-# if *$gunzip->{Append} ;
-# $fh = new IO::File "$mode $output"
-# or return $gunzip->saveErrorString(undef, "cannot open file '$output': $!", $!) ;
-# }
-#
-# if ($outType eq 'handle') {
-# $fh = $output;
-# if (*$gunzip->{Append}) {
-# seek($fh, 0, SEEK_END)
-# or return $gunzip->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
-# }
-# }
-#
-# my $buff = '' ;
-# $buff = $output if $outType eq 'buffer' ;
-# my $status ;
-# while (($status = $gunzip->read($buff)) > 0) {
-# if ($fh) {
-# print $fh $buff
-# or return $gunzip->saveErrorString(undef, "Error writing to output file: $!", $!);
-# }
-# }
-#
-# return undef
-# if $status < 0 ;
-#
-# $gunzip->close()
-# or return undef ;
-#
-# if ( $outType eq 'filename' ||
-# ($outType eq 'handle' && *$gunzip->{AutoClose})) {
-# $fh->close()
-# or return $gunzip->saveErrorString(undef, $!, $!);
-# }
-#
-# return 1 ;
-#}
-
-sub _inf
-{
- my $class = shift ;
- my $type = shift ;
- my $error_ref = shift ;
-
- my $name = (caller(1))[3] ;
-
- croak "$name: expected at least 1 parameters\n"
- unless @_ >= 1 ;
-
- my $input = shift ;
- my $haveOut = @_ ;
- my $output = shift ;
-
- my $x = new Validator($class, $type, $error_ref, $name, $input, $output)
- or return undef ;
-
- push @_, $output if $haveOut && $x->{Hash};
-
- my $got = checkParams($name, $type, @_)
- or return undef ;
-
- $x->{Got} = $got ;
-
- if ($x->{Hash})
- {
- while (my($k, $v) = each %$input)
- {
- $v = \$input->{$k}
- unless defined $v ;
-
- _singleTarget($x, 1, $k, $v, @_)
- or return undef ;
- }
-
- return keys %$input ;
- }
-
- if ($x->{GlobMap})
- {
- $x->{oneInput} = 1 ;
- foreach my $pair (@{ $x->{Pairs} })
- {
- my ($from, $to) = @$pair ;
- _singleTarget($x, 1, $from, $to, @_)
- or return undef ;
- }
-
- return scalar @{ $x->{Pairs} } ;
- }
-
- #if ($x->{outType} eq 'array' || $x->{outType} eq 'hash')
- if (! $x->{oneOutput} )
- {
- my $inFile = ($x->{inType} eq 'filenames'
- || $x->{inType} eq 'filename');
-
- $x->{inType} = $inFile ? 'filename' : 'buffer';
- my $ot = $x->{outType} ;
- $x->{outType} = 'buffer';
-
- foreach my $in ($x->{oneInput} ? $input : @$input)
- {
- my $out ;
- $x->{oneInput} = 1 ;
-
- _singleTarget($x, $inFile, $in, \$out, @_)
- or return undef ;
-
- if ($ot eq 'array')
- { push @$output, \$out }
- else
- { $output->{$in} = \$out }
- }
-
- return 1 ;
- }
-
- # finally the 1 to 1 and n to 1
- return _singleTarget($x, 1, $input, $output, @_);
-
- croak "should not be here" ;
-}
-
-sub retErr
-{
- my $x = shift ;
- my $string = shift ;
-
- ${ $x->{Error} } = $string ;
-
- return undef ;
-}
-
-sub _singleTarget
-{
- my $x = shift ;
- my $inputIsFilename = shift;
- my $input = shift;
- my $output = shift;
-
- $x->{buff} = '' ;
-
- my $fh ;
- if ($x->{outType} eq 'filename') {
- my $mode = '>' ;
- $mode = '>>'
- if $x->{Got}->value('Append') ;
- $x->{fh} = new IO::File "$mode $output"
- or return retErr($x, "cannot open file '$output': $!") ;
- binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
-
- }
-
- elsif ($x->{outType} eq 'handle') {
- $x->{fh} = $output;
- binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
- if ($x->{Got}->value('Append')) {
- seek($x->{fh}, 0, SEEK_END)
- or return retErr($x, "Cannot seek to end of output filehandle: $!") ;
- }
- }
-
-
- elsif ($x->{outType} eq 'buffer' )
- {
- $$output = ''
- unless $x->{Got}->value('Append');
- $x->{buff} = $output ;
- }
-
- if ($x->{oneInput})
- {
- defined _rd2($x, $input, $inputIsFilename)
- or return undef;
- }
- else
- {
- my $inputIsFilename = ($x->{inType} ne 'array');
-
- for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
- {
- defined _rd2($x, $element, $inputIsFilename)
- or return undef ;
- }
- }
-
-
- if ( ($x->{outType} eq 'filename' && $output ne '-') ||
- ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) {
- $x->{fh}->close()
- or return retErr($x, $!);
- #or return $gunzip->saveErrorString(undef, $!, $!);
- delete $x->{fh};
- }
-
- return 1 ;
-}
-
-sub _rd2
-{
- my $x = shift ;
- my $input = shift;
- my $inputIsFilename = shift;
-
- my $gunzip = new($x->{Class}, $x->{Type}, $x->{Got}, $x->{Error}, 1, $input, @_)
- or return undef ;
-
- my $status ;
- my $fh = $x->{fh};
-
- while (($status = $gunzip->read($x->{buff})) > 0) {
- if ($fh) {
- print $fh $x->{buff}
- or return $gunzip->saveErrorString(undef, "Error writing to output file: $!", $!);
- $x->{buff} = '' ;
- }
- }
-
- return undef
- if $status < 0 ;
-
- $gunzip->close()
- or return undef ;
-
- return 1 ;
-}
-
-sub TIEHANDLE
-{
- return $_[0] if ref($_[0]);
- die "OOPS\n" ;
-
-}
-
-sub UNTIE
-{
- my $self = shift ;
-}
-
-
-sub getHeaderInfo
-{
- my $self = shift ;
- return *$self->{Info};
-}
-
-sub _raw_read
-{
- # return codes
- # >0 - ok, number of bytes read
- # =0 - ok, eof
- # <0 - not ok
-
- my $self = shift ;
-
- return G_EOF if *$self->{Closed} ;
- #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
- return G_EOF if *$self->{EndStream} ;
-
- my $buffer = shift ;
- my $scan_mode = shift ;
-
- if (*$self->{Plain}) {
- my $tmp_buff ;
- my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ;
-
- return $self->saveErrorString(G_ERR, "Error reading data: $!", $!)
- if $len < 0 ;
-
- if ($len == 0 ) {
- *$self->{EndStream} = 1 ;
- }
- else {
- *$self->{PlainBytesRead} += $len ;
- $$buffer .= $tmp_buff;
- }
-
- return $len ;
- }
-
- if (*$self->{NewStream}) {
- *$self->{NewStream} = 0 ;
- *$self->{EndStream} = 0 ;
- *$self->{Inflate}->inflateReset();
-
- if (*$self->{Type} eq 'rfc1952')
- {
- *$self->{Info} = $self->_readFullGzipHeader() ;
- }
- elsif (*$self->{Type} eq 'zip')
- {
- *$self->{Info} = $self->_readFullZipHeader() ;
- }
- elsif (*$self->{Type} eq 'rfc1950')
- {
- *$self->{Info} = $self->_readDeflateHeader() ;
- }
- elsif (*$self->{Type} eq 'rfc1951')
- {
- *$self->{Info} = $self->_isRaw() ;
- *$self->{Pending} = *$self->{HeaderPending}
- if defined *$self->{Info} ;
- }
-
- return G_ERR unless defined *$self->{Info} ;
-
- push @{ *$self->{InfoList} }, *$self->{Info} ;
-
- if (*$self->{Type} eq 'rfc1951') {
- $$buffer .= *$self->{Pending} ;
- my $len = length *$self->{Pending} ;
- *$self->{Pending} = '';
- return $len;
- }
- }
-
- my $temp_buf ;
- my $status = $self->smartRead(\$temp_buf, *$self->{BlockSize}) ;
- return $self->saveErrorString(G_ERR, "Error Reading Data")
- if $status < 0 ;
-
- if ($status == 0 ) {
- *$self->{Closed} = 1 ;
- *$self->{EndStream} = 1 ;
- return $self->saveErrorString(G_ERR, "unexpected end of file", Z_DATA_ERROR);
- }
-
- my $before_len = defined $$buffer ? length $$buffer : 0 ;
- $status = *$self->{Inflate}->inflate(\$temp_buf, $buffer) ;
-
- return $self->saveErrorString(G_ERR, "Inflation Error: $status")
- unless $self->saveStatus($status) == Z_OK || $status == Z_STREAM_END ;
-
- my $buf_len = *$self->{Inflate}->inflateCount();
-
- # zlib before 1.2 needs an extra byte after the compressed data
- # for RawDeflate
- if ($status == Z_OK && *$self->{Type} eq 'rfc1951' && $self->smartEof()) {
- my $byte = ' ';
- $status = *$self->{Inflate}->inflate(\$byte, $buffer) ;
-
- $buf_len += *$self->{Inflate}->inflateCount();
-
- return $self->saveErrorString(G_ERR, "Inflation Error: $status")
- unless $self->saveStatus($status) == Z_OK || $status == Z_STREAM_END ;
- }
-
-
- return $self->saveErrorString(G_ERR, "unexpected end of file", Z_DATA_ERROR)
- if $status != Z_STREAM_END && $self->smartEof() ;
-
- *$self->{InflatedBytesRead} += $buf_len ;
- *$self->{TotalInflatedBytesRead} += $buf_len ;
- my $rest = GZIP_ISIZE_MAX - *$self->{ISize} ;
- if ($buf_len > $rest) {
- *$self->{ISize} = $buf_len - $rest - 1;
- }
- else {
- *$self->{ISize} += $buf_len ;
- }
-
- if ($status == Z_STREAM_END) {
-
- *$self->{EndStream} = 1 ;
-
- if (*$self->{Type} eq 'rfc1951' || ! *$self->{Info}{TrailerLength})
- {
- *$self->{Trailing} = $temp_buf . $self->getTrailingBuffer();
- }
- else
- {
- # Only rfc1950 & 1952 have a trailer
-
- my $trailer_size = *$self->{Info}{TrailerLength} ;
-
- #if ($scan_mode) {
- # my $offset = *$self->{Inflate}->getLastBufferOffset();
- # substr($temp_buf, 0, $offset) = '' ;
- #}
-
- if (length $temp_buf < $trailer_size) {
- my $buff;
- my $want = $trailer_size - length $temp_buf;
- my $got = $self->smartRead(\$buff, $want) ;
- if ($got != $want && *$self->{Strict} ) {
- my $len = length($temp_buf) + length($buff);
- return $self->TrailerError("trailer truncated. Expected " .
- "$trailer_size bytes, got $len");
- }
- $temp_buf .= $buff;
- }
-
- if (length $temp_buf >= $trailer_size) {
-
- #my $trailer = substr($temp_buf, 0, $trailer_size, '') ;
- my $trailer = substr($temp_buf, 0, $trailer_size) ;
- substr($temp_buf, 0, $trailer_size) = '' ;
-
- if (*$self->{Type} eq 'rfc1952') {
- # Check CRC & ISIZE
- my ($CRC32, $ISIZE) = unpack("V V", $trailer) ;
- *$self->{Info}{CRC32} = $CRC32;
- *$self->{Info}{ISIZE} = $ISIZE;
-
- if (*$self->{Strict}) {
- return $self->TrailerError("CRC mismatch")
- if $CRC32 != *$self->{Inflate}->crc32() ;
-
- my $exp_isize = *$self->{ISize};
- return $self->TrailerError("ISIZE mismatch. Got $ISIZE"
- . ", expected $exp_isize")
- if $ISIZE != $exp_isize ;
- }
- }
- elsif (*$self->{Type} eq 'zip') {
- # Check CRC & ISIZE
- my ($sig, $CRC32, $cSize, $uSize) = unpack("V V V V", $trailer) ;
- return $self->TrailerError("Data Descriptor signature")
- if $sig != 0x08074b50;
-
- if (*$self->{Strict}) {
- return $self->TrailerError("CRC mismatch")
- if $CRC32 != *$self->{Inflate}->crc32() ;
-
- }
- }
- elsif (*$self->{Type} eq 'rfc1950') {
- my $ADLER32 = unpack("N", $trailer) ;
- *$self->{Info}{ADLER32} = $ADLER32;
- return $self->TrailerError("CRC mismatch")
- if *$self->{Strict} && $ADLER32 != *$self->{Inflate}->adler32() ;
-
- }
-
- if (*$self->{MultiStream}
- && (length $temp_buf || ! $self->smartEof())){
- *$self->{NewStream} = 1 ;
- *$self->{EndStream} = 0 ;
- *$self->{Prime} = $temp_buf . *$self->{Prime} ;
- return $buf_len ;
- }
- }
-
- *$self->{Trailing} = $temp_buf .$self->getTrailingBuffer();
- }
- }
-
-
- # return the number of uncompressed bytes read
- return $buf_len ;
-}
-
-#sub isEndStream
-#{
-# my $self = shift ;
-# return *$self->{NewStream} ||
-# *$self->{EndStream} ;
-#}
-
-sub streamCount
-{
- my $self = shift ;
- return 1 if ! defined *$self->{InfoList};
- return scalar @{ *$self->{InfoList} } ;
-}
-
-sub read
-{
- # return codes
- # >0 - ok, number of bytes read
- # =0 - ok, eof
- # <0 - not ok
-
- my $self = shift ;
-
- return G_EOF if *$self->{Closed} ;
- return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
-
- my $buffer ;
-
- #croak(*$self->{ClassName} . "::read: buffer parameter is read-only")
- # if Compress::Zlib::_readonly_ref($_[0]);
-
- if (ref $_[0] ) {
- croak(*$self->{ClassName} . "::read: buffer parameter is read-only")
- if readonly(${ $_[0] });
-
- croak *$self->{ClassName} . "::read: not a scalar reference $_[0]"
- unless ref $_[0] eq 'SCALAR' ;
- $buffer = $_[0] ;
- }
- else {
- croak(*$self->{ClassName} . "::read: buffer parameter is read-only")
- if readonly($_[0]);
-
- $buffer = \$_[0] ;
- }
-
- my $length = $_[1] ;
- my $offset = $_[2] || 0;
-
- # the core read will return 0 if asked for 0 bytes
- return 0 if defined $length && $length == 0 ;
-
- $length = $length || 0;
-
- croak(*$self->{ClassName} . "::read: length parameter is negative")
- if $length < 0 ;
-
- $$buffer = '' unless *$self->{AppendOutput} || $offset ;
-
- # Short-circuit if this is a simple read, with no length
- # or offset specified.
- unless ( $length || $offset) {
- if (length *$self->{Pending}) {
- $$buffer .= *$self->{Pending} ;
- my $len = length *$self->{Pending};
- *$self->{Pending} = '' ;
- return $len ;
- }
- else {
- my $len = 0;
- $len = $self->_raw_read($buffer)
- while ! *$self->{EndStream} && $len == 0 ;
- return $len ;
- }
- }
-
- # Need to jump through more hoops - either length or offset
- # or both are specified.
- #*$self->{Pending} = '' if ! length *$self->{Pending} ;
- my $out_buffer = \*$self->{Pending} ;
-
- while (! *$self->{EndStream} && length($$out_buffer) < $length)
- {
- my $buf_len = $self->_raw_read($out_buffer);
- return $buf_len
- if $buf_len < 0 ;
- }
-
- $length = length $$out_buffer
- if length($$out_buffer) < $length ;
-
- if ($offset) {
- $$buffer .= "\x00" x ($offset - length($$buffer))
- if $offset > length($$buffer) ;
- #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ;
- substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ;
- substr($$out_buffer, 0, $length) = '' ;
- }
- else {
- #$$buffer .= substr($$out_buffer, 0, $length, '') ;
- $$buffer .= substr($$out_buffer, 0, $length) ;
- substr($$out_buffer, 0, $length) = '' ;
- }
-
- return $length ;
-}
-
-sub _getline
-{
- my $self = shift ;
-
- # Slurp Mode
- if ( ! defined $/ ) {
- my $data ;
- 1 while $self->read($data) > 0 ;
- return \$data ;
- }
-
- # Paragraph Mode
- if ( ! length $/ ) {
- my $paragraph ;
- while ($self->read($paragraph) > 0 ) {
- if ($paragraph =~ s/^(.*?\n\n+)//s) {
- *$self->{Pending} = $paragraph ;
- my $par = $1 ;
- return \$par ;
- }
- }
- return \$paragraph;
- }
-
- # Line Mode
- {
- my $line ;
- my $endl = quotemeta($/); # quote in case $/ contains RE meta chars
- while ($self->read($line) > 0 ) {
- if ($line =~ s/^(.*?$endl)//s) {
- *$self->{Pending} = $line ;
- $. = ++ *$self->{LineNo} ;
- my $l = $1 ;
- return \$l ;
- }
- }
- $. = ++ *$self->{LineNo} if defined($line);
- return \$line;
- }
-}
+$VERSION = '2.000_07';
-sub getline
+sub new
{
- my $self = shift;
- my $current_append = *$self->{AppendOutput} ;
- *$self->{AppendOutput} = 1;
- my $lineref = $self->_getline();
- *$self->{AppendOutput} = $current_append;
- return $$lineref ;
-}
+ my $class = shift ;
+ $GunzipError = '';
+ my $obj = createSelfTiedObject($class, \$GunzipError);
-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;
+ $obj->_create(undef, 0, @_);
}
-sub READLINE
+sub gunzip
{
- goto &getlines if wantarray;
- goto &getline;
+ my $obj = createSelfTiedObject(undef, \$GunzipError);
+ return $obj->_inf(@_) ;
}
-sub getc
+sub getExtraParams
{
- my $self = shift;
- my $buf;
- return $buf if $self->read($buf, 1);
- return undef;
+ use Compress::Zlib::ParseParameters ;
+ return ( 'ParseExtra' => [1, 1, Parse_boolean, 0] ) ;
}
-sub ungetc
+sub ckParams
{
- my $self = shift;
- *$self->{Pending} = "" unless defined *$self->{Pending} ;
- *$self->{Pending} = $_[0] . *$self->{Pending} ;
-}
+ my $self = shift ;
+ my $got = shift ;
+ # gunzip always needs crc32
+ $got->value('CRC32' => 1);
-sub trailingData
-{
- my $self = shift ;
- return \"" if ! defined *$self->{Trailing} ;
- return \*$self->{Trailing} ;
+ return 1;
}
-sub inflateSync
+sub ckMagic
{
- 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} ;
+ my $self = shift;
- # Disable CRC check
- *$self->{Strict} = 0 ;
+ my $magic ;
+ $self->smartReadExact(\$magic, GZIP_ID_SIZE);
- my $status ;
- while (1)
- {
- my $temp_buf ;
+ *$self->{HeaderPending} = $magic ;
- 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) ;
+ return $self->HeaderError("Minimum header size is " .
+ GZIP_MIN_HEADER_SIZE . " bytes")
+ if length $magic != GZIP_ID_SIZE ;
- if ($status == Z_OK)
- {
- *$self->{Pending} .= $temp_buf ;
- return 1 ;
- }
+ return $self->HeaderError("Bad Magic")
+ if ! isGzipMagic($magic) ;
- last unless $status = Z_DATA_ERROR ;
- }
+ *$self->{Type} = 'rfc1952';
- return 0;
+ return $magic ;
}
-sub eof
+sub readHeader
{
- my $self = shift ;
+ my $self = shift;
+ my $magic = shift;
- return (*$self->{Closed} ||
- (!length *$self->{Pending}
- && ( $self->smartEof() || *$self->{EndStream}))) ;
+ return $self->_readGzipHeader($magic);
}
-sub tell
+sub chkTrailer
{
- my $self = shift ;
+ my $self = shift;
+ my $trailer = shift;
- my $in ;
- if (*$self->{Plain}) {
- $in = *$self->{PlainBytesRead} ;
- }
- else {
- $in = *$self->{TotalInflatedBytesRead} ;
+ # Check CRC & ISIZE
+ my ($CRC32, $ISIZE) = unpack("V V", $trailer) ;
+ *$self->{Info}{CRC32} = $CRC32;
+ *$self->{Info}{ISIZE} = $ISIZE;
+
+ if (*$self->{Strict}) {
+ return $self->TrailerError("CRC mismatch")
+ if $CRC32 != *$self->{Uncomp}->crc32() ;
+
+ my $exp_isize = *$self->{Uncomp}->uncompressedBytes();
+ return $self->TrailerError("ISIZE mismatch. Got $ISIZE"
+ . ", expected $exp_isize")
+ if $ISIZE != $exp_isize ;
}
- my $pending = length *$self->{Pending} ;
+ return 1;
+}
- return 0 if $pending > $in ;
- return $in - $pending ;
+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 close
+sub _readFullGzipHeader($)
{
- # todo - what to do if close is called before the end of the gzip file
- # do we remember any trailing data?
- my $self = shift ;
+ my ($self) = @_ ;
+ my $magic = '' ;
- return 1 if *$self->{Closed} ;
+ $self->smartReadExact(\$magic, GZIP_ID_SIZE);
- untie *$self
- if $] >= 5.008 ;
+ *$self->{HeaderPending} = $magic ;
- my $status = 1 ;
+ return $self->HeaderError("Minimum header size is " .
+ GZIP_MIN_HEADER_SIZE . " bytes")
+ if length $magic != GZIP_ID_SIZE ;
- 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;
-}
+ return $self->HeaderError("Bad Magic")
+ if ! isGzipMagic($magic) ;
-sub DESTROY
-{
- my $self = shift ;
- $self->close() ;
+ my $status = $self->_readGzipHeader($magic);
+ delete *$self->{Transparent} if ! defined $status ;
+ return $status ;
}
-sub seek
+sub _readGzipHeader($)
{
- my $self = shift ;
- my $position = shift;
- my $whence = shift ;
-
- my $here = $self->tell() ;
- my $target = 0 ;
-
+ my ($self, $magic) = @_ ;
+ my ($HeaderCRC) ;
+ my ($buffer) = '' ;
- 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";
- }
+ $self->smartReadExact(\$buffer, GZIP_MIN_HEADER_SIZE - GZIP_ID_SIZE)
+ or return $self->HeaderError("Minimum header size is " .
+ GZIP_MIN_HEADER_SIZE . " bytes") ;
- # short circuit if seeking to current offset
- return 1 if $target == $here ;
+ my $keep = $magic . $buffer ;
+ *$self->{HeaderPending} = $keep ;
- # Outlaw any attempt to seek backwards
- croak *$self->{ClassName} ."::seek: cannot seek backwards"
- if $target < $here ;
+ # now split out the various parts
+ my ($cm, $flag, $mtime, $xfl, $os) = unpack("C C V C C", $buffer) ;
- # Walk the file to the new offset
- my $offset = $target - $here ;
+ $cm == GZIP_CM_DEFLATED
+ or return $self->HeaderError("Not Deflate (CM is $cm)") ;
- my $buffer ;
- $self->read($buffer, $offset) == $offset
- or return 0 ;
+ # check for use of reserved bits
+ return $self->HeaderError("Use of Reserved Bits in FLG field.")
+ if $flag & GZIP_FLG_RESERVED ;
- return 1 ;
-}
+ my $EXTRA ;
+ my @EXTRA = () ;
+ if ($flag & GZIP_FLG_FEXTRA) {
+ $EXTRA = "" ;
+ $self->smartReadExact(\$buffer, GZIP_FEXTRA_HEADER_SIZE)
+ or return $self->TruncatedHeader("FEXTRA Length") ;
-sub fileno
-{
- my $self = shift ;
- return defined *$self->{FH}
- ? fileno *$self->{FH}
- : undef ;
-}
+ my ($XLEN) = unpack("v", $buffer) ;
+ $self->smartReadExact(\$EXTRA, $XLEN)
+ or return $self->TruncatedHeader("FEXTRA Body");
+ $keep .= $buffer . $EXTRA ;
-sub binmode
-{
- 1;
-# my $self = shift ;
-# return defined *$self->{FH}
-# ? binmode *$self->{FH}
-# : 1 ;
-}
+ if ($XLEN && *$self->{'ParseExtra'}) {
+ my $offset = 0 ;
+ while ($offset < $XLEN) {
-*BINMODE = \&binmode;
-*SEEK = \&seek;
-*READ = \&read;
-*sysread = \&read;
-*TELL = \&tell;
-*EOF = \&eof;
+ return $self->TruncatedHeader("FEXTRA Body")
+ if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
-*FILENO = \&fileno;
-*CLOSE = \&close;
+ my $id = substr($EXTRA, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
+ $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE ;
-sub _notAvailable
-{
- my $name = shift ;
- #return sub { croak "$name Not Available" ; } ;
- return sub { croak "$name Not Available: File opened only for intput" ; } ;
-}
+ 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 ;
-*print = _notAvailable('print');
-*PRINT = _notAvailable('print');
-*printf = _notAvailable('printf');
-*PRINTF = _notAvailable('printf');
-*write = _notAvailable('write');
-*WRITE = _notAvailable('write');
+ return $self->TruncatedHeader("FEXTRA Body")
+ if $offset + $subLen > $XLEN ;
-#*sysread = \&read;
-#*syswrite = \&_notAvailable;
+ push @EXTRA, [$id => substr($EXTRA, $offset, $subLen)];
+ $offset += $subLen ;
+ }
+ }
+ }
-#package IO::_infScan ;
-#
-#*_raw_read = \&IO::BaseInflate::_raw_read ;
-#*smartRead = \&IO::BaseInflate::smartRead ;
-#*smartWrite = \&IO::BaseInflate::smartWrite ;
-#*smartSeek = \&IO::BaseInflate::smartSeek ;
+ 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 ;
-sub scan
-{
- my $self = shift ;
+ return $self->HeaderError("Non ISO 8859-1 Character found in Name")
+ if *$self->{Strict} && $origname =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ;
+ }
- return 1 if *$self->{Closed} ;
- return 1 if !length *$self->{Pending} && *$self->{EndStream} ;
+ 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 ;
- my $buffer = '' ;
- my $len = 0;
+ return $self->HeaderError("Non ISO 8859-1 Character found in Comment")
+ if *$self->{Strict} && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o ;
+ }
- $len = $self->_raw_read(\$buffer, 1)
- while ! *$self->{EndStream} && $len >= 0 ;
+ if ($flag & GZIP_FLG_FHCRC) {
+ $self->smartReadExact(\$buffer, GZIP_FHCRC_SIZE)
+ or return $self->TruncatedHeader("FHCRC");
- #return $len if $len < 0 ? $len : 0 ;
- return $len < 0 ? 0 : 1 ;
-}
+ $HeaderCRC = unpack("v", $buffer) ;
+ my $crc16 = crc32($keep) & 0xFF ;
-sub zap
-{
- my $self = shift ;
+ return $self->HeaderError("CRC16 mismatch.")
+ if *$self->{Strict} && $crc16 != $HeaderCRC;
- my $headerLength = *$self->{Info}{HeaderLength};
- my $block_offset = $headerLength + *$self->{Inflate}->getLastBlockOffset();
- $_[0] = $headerLength + *$self->{Inflate}->getEndOffset();
- #printf "# End $_[0], headerlen $headerLength \n";;
+ $keep .= $buffer ;
+ }
- #printf "# block_offset $block_offset %x\n", $block_offset;
- my $byte ;
- ( $self->smartSeek($block_offset) &&
- $self->smartRead(\$byte, 1) )
- or return $self->saveErrorString(0, $!, $!);
+ # Assume compression method is deflated for xfl tests
+ #if ($xfl) {
+ #}
- #printf "#byte is %x\n", unpack('C*',$byte);
- *$self->{Inflate}->resetLastBlockByte($byte);
- #printf "#to byte is %x\n", unpack('C*',$byte);
+ *$self->{Type} = 'rfc1952';
- ( $self->smartSeek($block_offset) &&
- $self->smartWrite($byte) )
- or return $self->saveErrorString(0, $!, $!);
+ return {
+ 'Type' => 'rfc1952',
+ 'FingerprintLength' => 2,
+ 'HeaderLength' => length $keep,
+ 'TrailerLength' => GZIP_TRAILER_SIZE,
+ 'Header' => $keep,
+ 'isMinimalHeader' => $keep eq GZIP_MINIMUM_HEADER ? 1 : 0,
- #$self->smartSeek($end_offset, 1);
+ '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 ],
- 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 ;
+ #'CompSize'=> $compsize,
+ #'CRC32'=> $CRC32,
+ #'OrigSize'=> $ISIZE,
+ }
}
-package IO::Uncompress::Gunzip ;
+1;
-1 ;
__END__
-This module provides a Perl interface that allows the reading of
+This module provides a Perl interface that allows the reading of
files/buffers that conform to RFC 1952.
-For writing RFC 1952 files/buffers, see the companion module
-IO::Compress::Gzip.
+For writing RFC 1952 files/buffers, see the companion module IO::Compress::Gzip.
=head1 Functional Interface
-A top-level function, C<gunzip>, is provided to carry out "one-shot"
-uncompression between buffers and/or files. For finer control over the uncompression process, see the L</"OO Interface"> section.
+A top-level function, C<gunzip>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;
gunzip $input => $output [,OPTS]
or die "gunzip failed: $GunzipError\n";
- gunzip \%hash [,OPTS]
- or die "gunzip failed: $GunzipError\n";
+
The functional interface needs Perl5.005 or better.
=head2 gunzip $input => $output [, OPTS]
-If the first parameter is not a hash reference C<gunzip> expects
-at least two parameters, C<$input> and C<$output>.
+
+C<gunzip> expects at least two parameters, C<$input> and C<$output>.
=head3 The C<$input> parameter
=item An array reference
-If C<$input> is an array reference, the input data will be read from each
-element of the array in turn. The action taken by C<gunzip> with
-each element of the array will depend on the type of data stored
-in it. You can mix and match any of the types defined in this list,
-excluding other array or hash references.
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
The complete array will be walked to ensure that it only
-contains valid data types before any data is uncompressed.
+contains valid filenames before any data is uncompressed.
+
+
=item An Input FileGlob string
=item A filename
-If the C<$output> parameter is a simple scalar, it is assumed to be a filename.
-This file will be opened for writing and the uncompressed data will be
-written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output> parameter is a filehandle, the uncompressed data will
-be written to it.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output> is a scalar reference, the uncompressed data will be stored
-in C<$$output>.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
-=item A Hash Reference
-
-If C<$output> is a hash reference, the uncompressed data will be written
-to C<$output{$input}> as a scalar reference.
-
-When C<$output> is a hash reference, C<$input> must be either a filename or
-list of filenames. Anything else is an error.
-
=item An Array Reference
-If C<$output> is an array reference, the uncompressed data will be pushed
-onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
If the C<$output> parameter is any other type, C<undef> will be returned.
-=head2 gunzip \%hash [, OPTS]
-
-If the first parameter is a hash reference, C<\%hash>, this will be used to
-define both the source of compressed data and to control where the
-uncompressed data is output. Each key/value pair in the hash defines a
-mapping between an input filename, stored in the key, and an output
-file/buffer, stored in the value. Although the input can only be a filename,
-there is more flexibility to control the destination of the uncompressed
-data. This is determined by the type of the value. Valid types are
-
-=over 5
-
-=item undef
-
-If the value is C<undef> the uncompressed data will be written to the
-value as a scalar reference.
-
-=item A filename
-
-If the value is a simple scalar, it is assumed to be a filename. This file will
-be opened for writing and the uncompressed data will be written to it.
-
-=item A filehandle
-
-If the value is a filehandle, the uncompressed data will be
-written to it.
-The string '-' can be used as an alias for standard output.
-
-=item A scalar reference
-
-If the value is a scalar reference, the uncompressed data will be stored
-in the buffer that is referenced by the scalar.
-
-
-=item A Hash Reference
-
-If the value is a hash reference, the uncompressed data will be written
-to C<$hash{$input}> as a scalar reference.
-
-=item An Array Reference
-
-If C<$output> is an array reference, the uncompressed data will be pushed
-onto the array.
-
-=back
-
-Any other type is a error.
=head2 Notes
When C<$input> maps to multiple files/buffers and C<$output> is a single
-file/buffer the uncompressed input files/buffers will all be stored in
-C<$output> as a single uncompressed stream.
+file/buffer the uncompressed input files/buffers will all be stored
+in C<$output> as a single uncompressed stream.
=item AutoClose =E<gt> 0|1
-This option applies to any input or output data streams to C<gunzip>
-that are filehandles.
+This option applies to any input or output data streams to
+C<gunzip> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<gunzip> has
+=item BinModeOut =E<gt> 0|1
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+
+
+
+
=item -Append =E<gt> 0|1
TODO
+=item -MultiStream =E<gt> 0|1
+
+Creates a new stream after each file.
+
+Defaults to 1.
+
=back
Returns an C<IO::Uncompress::Gunzip> object on success and undef on failure.
The variable C<$GunzipError> will contain an error message on failure.
-If you are running Perl 5.005 or better the object, C<$z>, returned from
-IO::Uncompress::Gunzip can be used exactly like an L<IO::File|IO::File> filehandle.
-This means that all normal input file operations can be carried out with C<$z>.
-For example, to read a line from a compressed file/buffer you can use either
-of these forms
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::Gunzip can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
$line = $z->getline();
$line = <$z>;
This option can be useful when the compressed data is embedded in another
file/data structure and it is not possible to work out where the compressed
-data begins without having to read the first few bytes. If this is the case,
-the uncompression can be I<primed> with these bytes using this option.
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
=item -Transparent =E<gt> 0|1
=item -BlockSize =E<gt> $num
-When reading the compressed input data, IO::Uncompress::Gunzip will read it in blocks
-of C<$num> bytes.
+When reading the compressed input data, IO::Uncompress::Gunzip will read it in
+blocks of C<$num> bytes.
This option defaults to 4096.
=item -InputLength =E<gt> $size
-When present this option will limit the number of compressed bytes read from
-the input file/buffer to C<$size>. This option can be used in the situation
-where there is useful data directly after the compressed data stream and you
-know beforehand the exact length of the compressed data stream.
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
-This option is mostly used when reading from a filehandle, in which case the
-file pointer will be left pointing to the first byte directly after the
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
compressed data stream.
This option controls what the C<read> method does with uncompressed data.
-If set to 1, all uncompressed data will be appended to the output parameter of
-the C<read> method.
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
-If set to 0, the contents of the output parameter of the C<read> method will be
-overwritten by the uncompressed data.
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
Defaults to 0.
This option controls whether the extra checks defined below are used when
-carrying out the decompression. When Strict is on, the extra tests are carried
-out, when Strict is off they are not.
+carrying out the decompression. When Strict is on, the extra tests are
+carried out, when Strict is off they are not.
The default for this option is off.
=item 3
-If the gzip header contains a comment field (FCOMMENT) it consists solely of
-ISO 8859-1 characters plus line-feed.
+If the gzip header contains a comment field (FCOMMENT) it consists solely
+of ISO 8859-1 characters plus line-feed.
=item 4
=item 7
-The value of the ISIZE fields read must match the length of the uncompressed
-data actually read from the file.
+The value of the ISIZE fields read must match the length of the
+uncompressed data actually read from the file.
=back
Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
-writes any uncompressed data into C<$buffer>. If the C<Append> parameter is set
-in the constructor, the uncompressed data will be appended to the C<$buffer>
-parameter. Otherwise C<$buffer> will be overwritten.
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
-Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or
-a negative number on error.
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
=head2 read
Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
-The main difference between this form of the C<read> method and the previous
-one, is that this one will attempt to return I<exactly> C<$length> bytes. The
-only circumstances that this function will not is if end-of-file or an IO error
-is encountered.
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
-Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or
-a negative number on error.
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
=head2 getline
Usage is
- $hdr = $z->getHeaderInfo()
-
-TODO
-
-
-
-
-
-This method returns a hash reference that contains the contents of each of the
-header fields defined in RFC1952.
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
+=over 5
+=item Name
-=over 5
+The contents of the Name header field, if present. If no name is
+present, the value will be undef. Note this is different from a zero length
+name, which will return an empty string.
=item Comment
-The contents of the Comment header field, if present. If no comment is present,
-the value will be undef. Note this is different from a zero length comment,
-which will return an empty string.
+The contents of the Comment header field, if present. If no comment is
+present, the value will be undef. Note this is different from a zero length
+comment, which will return an empty string.
=back
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
use strict ;
use warnings;
-use IO::Uncompress::Gunzip ;
+use Compress::Zlib::Common qw(createSelfTiedObject);
+use Compress::Zlib::FileConstants;
+
+use IO::Uncompress::RawInflate ;
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError);
-$VERSION = '2.000_05';
+$VERSION = '2.000_07';
$InflateError = '';
-@ISA = qw( Exporter IO::BaseInflate );
+@ISA = qw( Exporter IO::Uncompress::RawInflate );
@EXPORT_OK = qw( $InflateError inflate ) ;
-%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ;
+%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
sub new
{
- my $pkg = shift ;
- return IO::BaseInflate::new($pkg, 'rfc1950', undef, \$InflateError, 0, @_);
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$InflateError);
+
+ $obj->_create(undef, 0, @_);
}
sub inflate
{
- return IO::BaseInflate::_inf(__PACKAGE__, 'rfc1950', \$InflateError, @_);
+ my $obj = createSelfTiedObject(undef, \$InflateError);
+ return $obj->_inf(@_);
+}
+
+sub getExtraParams
+{
+ return ();
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # gunzip always needs adler32
+ $got->value('ADLER32' => 1);
+
+ return 1;
+}
+
+sub ckMagic
+{
+ my $self = shift;
+
+ my $magic ;
+ $self->smartReadExact(\$magic, ZLIB_HEADER_SIZE);
+
+ *$self->{HeaderPending} = $magic ;
+
+ return $self->HeaderError("Header size is " .
+ ZLIB_HEADER_SIZE . " bytes")
+ if length $magic != ZLIB_HEADER_SIZE;
+
+ return $self->HeaderError("CRC mismatch.")
+ if ! isZlibMagic($magic) ;
+
+ *$self->{Type} = 'rfc1950';
+ return $magic;
+}
+
+sub readHeader
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ return $self->_readDeflateHeader($magic) ;
+}
+
+sub chkTrailer
+{
+ my $self = shift;
+ my $trailer = shift;
+
+ my $ADLER32 = unpack("N", $trailer) ;
+ *$self->{Info}{ADLER32} = $ADLER32;
+ return $self->TrailerError("CRC mismatch")
+ if *$self->{Strict} && $ADLER32 != *$self->{Uncomp}->adler32() ;
+
+ return 1;
+}
+
+
+
+sub isZlibMagic
+{
+ my $buffer = shift ;
+ return 0 if length $buffer < ZLIB_HEADER_SIZE ;
+ my $hdr = unpack("n", $buffer) ;
+ return $hdr % 31 == 0 ;
}
+sub bits
+{
+ my $data = shift ;
+ my $offset = shift ;
+ my $mask = shift ;
+
+ ($data >> $offset ) & $mask & 0xFF ;
+}
+
+
+sub _readDeflateHeader
+{
+ my ($self, $buffer) = @_ ;
+
+# if (! $buffer) {
+# $self->smartReadExact(\$buffer, ZLIB_HEADER_SIZE);
+#
+# *$self->{HeaderPending} = $buffer ;
+#
+# return $self->HeaderError("Header size is " .
+# ZLIB_HEADER_SIZE . " bytes")
+# if length $buffer != ZLIB_HEADER_SIZE;
+#
+# return $self->HeaderError("CRC mismatch.")
+# if ! isZlibMagic($buffer) ;
+# }
+
+ my ($CMF, $FLG) = unpack "C C", $buffer;
+ my $FDICT = bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ),
+
+ my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ;
+ $cm == ZLIB_CMF_CM_DEFLATED
+ or return $self->HeaderError("Not Deflate (CM is $cm)") ;
+
+ my $DICTID;
+ if ($FDICT) {
+ $self->smartReadExact(\$buffer, ZLIB_FDICT_SIZE)
+ or return $self->TruncatedHeader("FDICT");
+
+ $DICTID = unpack("N", $buffer) ;
+ }
+
+ *$self->{Type} = 'rfc1950';
+
+ return {
+ 'Type' => 'rfc1950',
+ 'FingerprintLength' => ZLIB_HEADER_SIZE,
+ 'HeaderLength' => ZLIB_HEADER_SIZE,
+ 'TrailerLength' => ZLIB_TRAILER_SIZE,
+ 'Header' => $buffer,
+
+ CMF => $CMF ,
+ CM => bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS ),
+ CINFO => bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS ),
+ FLG => $FLG ,
+ FCHECK => bits($FLG, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS),
+ FDICT => bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ),
+ FLEVEL => bits($FLG, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS ),
+ DICTID => $DICTID ,
+
+ };
+}
+
+
+
+
1 ;
__END__
-This module provides a Perl interface that allows the reading of
+This module provides a Perl interface that allows the reading of
files/buffers that conform to RFC 1950.
-For writing RFC 1950 files/buffers, see the companion module
-IO::Compress::Deflate.
+For writing RFC 1950 files/buffers, see the companion module IO::Compress::Deflate.
=head1 Functional Interface
-A top-level function, C<inflate>, is provided to carry out "one-shot"
-uncompression between buffers and/or files. For finer control over the uncompression process, see the L</"OO Interface"> section.
+A top-level function, C<inflate>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
use IO::Uncompress::Inflate qw(inflate $InflateError) ;
inflate $input => $output [,OPTS]
or die "inflate failed: $InflateError\n";
- inflate \%hash [,OPTS]
- or die "inflate failed: $InflateError\n";
+
The functional interface needs Perl5.005 or better.
=head2 inflate $input => $output [, OPTS]
-If the first parameter is not a hash reference C<inflate> expects
-at least two parameters, C<$input> and C<$output>.
+
+C<inflate> expects at least two parameters, C<$input> and C<$output>.
=head3 The C<$input> parameter
=item An array reference
-If C<$input> is an array reference, the input data will be read from each
-element of the array in turn. The action taken by C<inflate> with
-each element of the array will depend on the type of data stored
-in it. You can mix and match any of the types defined in this list,
-excluding other array or hash references.
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
The complete array will be walked to ensure that it only
-contains valid data types before any data is uncompressed.
+contains valid filenames before any data is uncompressed.
+
+
=item An Input FileGlob string
=item A filename
-If the C<$output> parameter is a simple scalar, it is assumed to be a filename.
-This file will be opened for writing and the uncompressed data will be
-written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output> parameter is a filehandle, the uncompressed data will
-be written to it.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output> is a scalar reference, the uncompressed data will be stored
-in C<$$output>.
-
-
-=item A Hash Reference
-
-If C<$output> is a hash reference, the uncompressed data will be written
-to C<$output{$input}> as a scalar reference.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
-When C<$output> is a hash reference, C<$input> must be either a filename or
-list of filenames. Anything else is an error.
=item An Array Reference
-If C<$output> is an array reference, the uncompressed data will be pushed
-onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
If the C<$output> parameter is any other type, C<undef> will be returned.
-=head2 inflate \%hash [, OPTS]
-
-If the first parameter is a hash reference, C<\%hash>, this will be used to
-define both the source of compressed data and to control where the
-uncompressed data is output. Each key/value pair in the hash defines a
-mapping between an input filename, stored in the key, and an output
-file/buffer, stored in the value. Although the input can only be a filename,
-there is more flexibility to control the destination of the uncompressed
-data. This is determined by the type of the value. Valid types are
-
-=over 5
-
-=item undef
-
-If the value is C<undef> the uncompressed data will be written to the
-value as a scalar reference.
-
-=item A filename
-
-If the value is a simple scalar, it is assumed to be a filename. This file will
-be opened for writing and the uncompressed data will be written to it.
-
-=item A filehandle
-
-If the value is a filehandle, the uncompressed data will be
-written to it.
-The string '-' can be used as an alias for standard output.
-
-
-=item A scalar reference
-
-If the value is a scalar reference, the uncompressed data will be stored
-in the buffer that is referenced by the scalar.
-
-
-=item A Hash Reference
-
-If the value is a hash reference, the uncompressed data will be written
-to C<$hash{$input}> as a scalar reference.
-
-=item An Array Reference
-If C<$output> is an array reference, the uncompressed data will be pushed
-onto the array.
-
-=back
-
-Any other type is a error.
=head2 Notes
When C<$input> maps to multiple files/buffers and C<$output> is a single
-file/buffer the uncompressed input files/buffers will all be stored in
-C<$output> as a single uncompressed stream.
+file/buffer the uncompressed input files/buffers will all be stored
+in C<$output> as a single uncompressed stream.
=item AutoClose =E<gt> 0|1
-This option applies to any input or output data streams to C<inflate>
-that are filehandles.
+This option applies to any input or output data streams to
+C<inflate> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<inflate> has
+=item BinModeOut =E<gt> 0|1
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+
+
+
+
=item -Append =E<gt> 0|1
TODO
+=item -MultiStream =E<gt> 0|1
+
+Creates a new stream after each file.
+
+Defaults to 1.
+
=back
Returns an C<IO::Uncompress::Inflate> object on success and undef on failure.
The variable C<$InflateError> will contain an error message on failure.
-If you are running Perl 5.005 or better the object, C<$z>, returned from
-IO::Uncompress::Inflate can be used exactly like an L<IO::File|IO::File> filehandle.
-This means that all normal input file operations can be carried out with C<$z>.
-For example, to read a line from a compressed file/buffer you can use either
-of these forms
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::Inflate can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
$line = $z->getline();
$line = <$z>;
This option can be useful when the compressed data is embedded in another
file/data structure and it is not possible to work out where the compressed
-data begins without having to read the first few bytes. If this is the case,
-the uncompression can be I<primed> with these bytes using this option.
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
=item -Transparent =E<gt> 0|1
=item -BlockSize =E<gt> $num
-When reading the compressed input data, IO::Uncompress::Inflate will read it in blocks
-of C<$num> bytes.
+When reading the compressed input data, IO::Uncompress::Inflate will read it in
+blocks of C<$num> bytes.
This option defaults to 4096.
=item -InputLength =E<gt> $size
-When present this option will limit the number of compressed bytes read from
-the input file/buffer to C<$size>. This option can be used in the situation
-where there is useful data directly after the compressed data stream and you
-know beforehand the exact length of the compressed data stream.
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
-This option is mostly used when reading from a filehandle, in which case the
-file pointer will be left pointing to the first byte directly after the
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
compressed data stream.
This option controls what the C<read> method does with uncompressed data.
-If set to 1, all uncompressed data will be appended to the output parameter of
-the C<read> method.
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
-If set to 0, the contents of the output parameter of the C<read> method will be
-overwritten by the uncompressed data.
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
Defaults to 0.
This option controls whether the extra checks defined below are used when
-carrying out the decompression. When Strict is on, the extra tests are carried
-out, when Strict is off they are not.
+carrying out the decompression. When Strict is on, the extra tests are
+carried out, when Strict is off they are not.
The default for this option is off.
Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
-writes any uncompressed data into C<$buffer>. If the C<Append> parameter is set
-in the constructor, the uncompressed data will be appended to the C<$buffer>
-parameter. Otherwise C<$buffer> will be overwritten.
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
-Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or
-a negative number on error.
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
=head2 read
Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
-The main difference between this form of the C<read> method and the previous
-one, is that this one will attempt to return I<exactly> C<$length> bytes. The
-only circumstances that this function will not is if end-of-file or an IO error
-is encountered.
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
-Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or
-a negative number on error.
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
=head2 getline
Usage is
- $hdr = $z->getHeaderInfo()
-
-TODO
-
-
-
-
-
-This method returns a hash reference that contains the contents of each of the
-header fields defined in RFC1950.
-
-
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
use strict ;
use warnings;
-use IO::Uncompress::Gunzip;
+
+use Compress::Zlib 2 ;
+use Compress::Zlib::Common qw(:Status createSelfTiedObject);
+use Compress::Zlib::ParseParameters ;
+
+use IO::Uncompress::Base ;
+use UncompressPlugin::Inflate ;
+
+
+
require Exporter ;
-our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $RawInflateError);
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError);
-$VERSION = '2.000_05';
+$VERSION = '2.000_07';
$RawInflateError = '';
-@ISA = qw(Exporter IO::BaseInflate);
+@ISA = qw( Exporter IO::Uncompress::Base );
@EXPORT_OK = qw( $RawInflateError rawinflate ) ;
-%EXPORT_TAGS = %IO::BaseInflate::EXPORT_TAGS ;
+%DEFLATE_CONSTANTS = ();
+%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
-
sub new
{
- my $pkg = shift ;
- return IO::BaseInflate::new($pkg, 'rfc1951', undef, \$RawInflateError, 0, @_);
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$RawInflateError);
+ $obj->_create(undef, 0, @_);
}
sub rawinflate
{
- return IO::BaseInflate::_inf(__PACKAGE__, 'rfc1951', \$RawInflateError, @_);
+ my $obj = createSelfTiedObject(undef, \$RawInflateError);
+ return $obj->_inf(@_);
+}
+
+sub getExtraParams
+{
+ return ();
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ return 1;
+}
+
+sub mkUncomp
+{
+ my $self = shift ;
+ my $class = shift ;
+ my $got = shift ;
+
+ my ($obj, $errstr, $errno) = UncompressPlugin::Inflate::mkUncompObject(
+ $got->value('CRC32'),
+ $got->value('ADLER32'),
+ $got->value('Scan'),
+ );
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ my $magic = $self->ckMagic()
+ or return 0;
+
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ return 1;
+
+}
+
+
+sub ckMagic
+{
+ my $self = shift;
+
+ return $self->_isRaw() ;
+}
+
+sub readHeader
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ return {
+ 'Type' => 'rfc1951',
+ 'FingerprintLength' => 0,
+ 'HeaderLength' => 0,
+ 'TrailerLength' => 0,
+ 'Header' => ''
+ };
+}
+
+sub chkTrailer
+{
+ return 1 ;
+}
+
+sub _isRaw
+{
+ my $self = shift ;
+
+ my $got = $self->_isRawx(@_);
+
+ if ($got) {
+ *$self->{Pending} = *$self->{HeaderPending} ;
+ }
+ else {
+ $self->pushBack(*$self->{HeaderPending});
+ *$self->{Uncomp}->reset();
+ }
+ *$self->{HeaderPending} = '';
+
+ return $got ;
}
+sub _isRawx
+{
+ my $self = shift ;
+ my $magic = shift ;
+
+ $magic = '' unless defined $magic ;
+
+ my $buffer = '';
+
+ $self->smartRead(\$buffer, *$self->{BlockSize}) >= 0
+ or return $self->saveErrorString(undef, "No data to read");
+
+ my $temp_buf = $magic . $buffer ;
+ *$self->{HeaderPending} = $temp_buf ;
+ $buffer = '';
+ my $status = *$self->{Uncomp}->uncompr(\$temp_buf, \$buffer, $self->smartEof()) ;
+ return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, STATUS_ERROR)
+ if $status == STATUS_ERROR;
+
+ my $buf_len = *$self->{Uncomp}->count();
+
+ if ($status == STATUS_ENDSTREAM) {
+ if (*$self->{MultiStream}
+ && (length $temp_buf || ! $self->smartEof())){
+ *$self->{NewStream} = 1 ;
+ *$self->{EndStream} = 0 ;
+ $self->pushBack($temp_buf);
+ }
+ else {
+ *$self->{EndStream} = 1 ;
+ $self->pushBack($temp_buf);
+ }
+ }
+ *$self->{HeaderPending} = $buffer ;
+ *$self->{InflatedBytesRead} = $buf_len ;
+ *$self->{TotalInflatedBytesRead} += $buf_len ;
+ *$self->{Type} = 'rfc1951';
+
+ $self->saveStatus(STATUS_OK);
+
+ return {
+ 'Type' => 'rfc1951',
+ 'HeaderLength' => 0,
+ 'TrailerLength' => 0,
+ 'Header' => ''
+ };
+}
+
+
+sub inflateSync
+{
+ my $self = shift ;
+
+ # inflateSync is a no-op in Plain mode
+ return 1
+ if *$self->{Plain} ;
+
+ return 0 if *$self->{Closed} ;
+ #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
+ return 0 if ! length *$self->{Pending} && *$self->{EndStream} ;
+
+ # Disable CRC check
+ *$self->{Strict} = 0 ;
+
+ my $status ;
+ while (1)
+ {
+ my $temp_buf ;
+
+ if (length *$self->{Pending} )
+ {
+ $temp_buf = *$self->{Pending} ;
+ *$self->{Pending} = '';
+ }
+ else
+ {
+ $status = $self->smartRead(\$temp_buf, *$self->{BlockSize}) ;
+ return $self->saveErrorString(0, "Error Reading Data")
+ if $status < 0 ;
+
+ if ($status == 0 ) {
+ *$self->{EndStream} = 1 ;
+ return $self->saveErrorString(0, "unexpected end of file", STATUS_ERROR);
+ }
+ }
+
+ $status = *$self->{Uncomp}->sync($temp_buf) ;
+
+ if ($status == STATUS_OK)
+ {
+ *$self->{Pending} .= $temp_buf ;
+ return 1 ;
+ }
+
+ last unless $status == STATUS_ERROR ;
+ }
+
+ return 0;
+}
+
+#sub performScan
+#{
+# my $self = shift ;
+#
+# my $status ;
+# my $end_offset = 0;
+#
+# $status = $self->scan()
+# #or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $self->errorNo) ;
+# or return $self->saveErrorString(G_ERR, "Error Scanning: $status")
+#
+# $status = $self->zap($end_offset)
+# or return $self->saveErrorString(G_ERR, "Error Zapping: $status");
+# #or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $self->errorNo) ;
+#
+# #(*$obj->{Deflate}, $status) = $inf->createDeflate();
+#
+## *$obj->{Header} = *$inf->{Info}{Header};
+## *$obj->{UnCompSize_32bit} =
+## *$obj->{BytesWritten} = *$inf->{UnCompSize_32bit} ;
+## *$obj->{CompSize_32bit} = *$inf->{CompSize_32bit} ;
+#
+#
+## if ( $outType eq 'buffer')
+## { substr( ${ *$self->{Buffer} }, $end_offset) = '' }
+## elsif ($outType eq 'handle' || $outType eq 'filename') {
+## *$self->{FH} = *$inf->{FH} ;
+## delete *$inf->{FH};
+## *$obj->{FH}->flush() ;
+## *$obj->{Handle} = 1 if $outType eq 'handle';
+##
+## #seek(*$obj->{FH}, $end_offset, SEEK_SET)
+## *$obj->{FH}->seek($end_offset, SEEK_SET)
+## or return $obj->saveErrorString(undef, $!, $!) ;
+## }
+#
+#}
+
+sub scan
+{
+ my $self = shift ;
+
+ return 1 if *$self->{Closed} ;
+ return 1 if !length *$self->{Pending} && *$self->{EndStream} ;
+
+ my $buffer = '' ;
+ my $len = 0;
+
+ $len = $self->_raw_read(\$buffer, 1)
+ while ! *$self->{EndStream} && $len >= 0 ;
+
+ #return $len if $len < 0 ? $len : 0 ;
+ return $len < 0 ? 0 : 1 ;
+}
+
+sub zap
+{
+ my $self = shift ;
+
+ my $headerLength = *$self->{Info}{HeaderLength};
+ my $block_offset = $headerLength + *$self->{Uncomp}->getLastBlockOffset();
+ $_[0] = $headerLength + *$self->{Uncomp}->getEndOffset();
+ #printf "# End $_[0], headerlen $headerLength \n";;
+ #printf "# block_offset $block_offset %x\n", $block_offset;
+ my $byte ;
+ ( $self->smartSeek($block_offset) &&
+ $self->smartRead(\$byte, 1) )
+ or return $self->saveErrorString(0, $!, $!);
+
+ #printf "#byte is %x\n", unpack('C*',$byte);
+ *$self->{Uncomp}->resetLastBlockByte($byte);
+ #printf "#to byte is %x\n", unpack('C*',$byte);
+
+ ( $self->smartSeek($block_offset) &&
+ $self->smartWrite($byte) )
+ or return $self->saveErrorString(0, $!, $!);
+
+ #$self->smartSeek($end_offset, 1);
+
+ return 1 ;
+}
+
+sub createDeflate
+{
+ my $self = shift ;
+ my ($def, $status) = *$self->{Uncomp}->createDeflateStream(
+ -AppendOutput => 1,
+ -WindowBits => - MAX_WBITS,
+ -CRC32 => *$self->{Params}->value('CRC32'),
+ -ADLER32 => *$self->{Params}->value('ADLER32'),
+ );
+
+ return wantarray ? ($status, $def) : $def ;
+}
+
+
1;
__END__
-This module provides a Perl interface that allows the reading of
+This module provides a Perl interface that allows the reading of
files/buffers that conform to RFC 1951.
-For writing RFC 1951 files/buffers, see the companion module
-IO::Compress::RawDeflate.
+For writing RFC 1951 files/buffers, see the companion module IO::Compress::RawDeflate.
=head1 Functional Interface
-A top-level function, C<rawinflate>, is provided to carry out "one-shot"
-uncompression between buffers and/or files. For finer control over the uncompression process, see the L</"OO Interface"> section.
+A top-level function, C<rawinflate>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ;
rawinflate $input => $output [,OPTS]
or die "rawinflate failed: $RawInflateError\n";
- rawinflate \%hash [,OPTS]
- or die "rawinflate failed: $RawInflateError\n";
+
The functional interface needs Perl5.005 or better.
=head2 rawinflate $input => $output [, OPTS]
-If the first parameter is not a hash reference C<rawinflate> expects
-at least two parameters, C<$input> and C<$output>.
+
+C<rawinflate> expects at least two parameters, C<$input> and C<$output>.
=head3 The C<$input> parameter
=item An array reference
-If C<$input> is an array reference, the input data will be read from each
-element of the array in turn. The action taken by C<rawinflate> with
-each element of the array will depend on the type of data stored
-in it. You can mix and match any of the types defined in this list,
-excluding other array or hash references.
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
The complete array will be walked to ensure that it only
-contains valid data types before any data is uncompressed.
+contains valid filenames before any data is uncompressed.
+
+
=item An Input FileGlob string
=item A filename
-If the C<$output> parameter is a simple scalar, it is assumed to be a filename.
-This file will be opened for writing and the uncompressed data will be
-written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output> parameter is a filehandle, the uncompressed data will
-be written to it.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output> is a scalar reference, the uncompressed data will be stored
-in C<$$output>.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
-=item A Hash Reference
-
-If C<$output> is a hash reference, the uncompressed data will be written
-to C<$output{$input}> as a scalar reference.
-
-When C<$output> is a hash reference, C<$input> must be either a filename or
-list of filenames. Anything else is an error.
-
=item An Array Reference
-If C<$output> is an array reference, the uncompressed data will be pushed
-onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
If the C<$output> parameter is any other type, C<undef> will be returned.
-=head2 rawinflate \%hash [, OPTS]
-
-If the first parameter is a hash reference, C<\%hash>, this will be used to
-define both the source of compressed data and to control where the
-uncompressed data is output. Each key/value pair in the hash defines a
-mapping between an input filename, stored in the key, and an output
-file/buffer, stored in the value. Although the input can only be a filename,
-there is more flexibility to control the destination of the uncompressed
-data. This is determined by the type of the value. Valid types are
-
-=over 5
-
-=item undef
-
-If the value is C<undef> the uncompressed data will be written to the
-value as a scalar reference.
-=item A filename
-
-If the value is a simple scalar, it is assumed to be a filename. This file will
-be opened for writing and the uncompressed data will be written to it.
-
-=item A filehandle
-
-If the value is a filehandle, the uncompressed data will be
-written to it.
-The string '-' can be used as an alias for standard output.
-
-
-=item A scalar reference
-
-If the value is a scalar reference, the uncompressed data will be stored
-in the buffer that is referenced by the scalar.
-
-
-=item A Hash Reference
-
-If the value is a hash reference, the uncompressed data will be written
-to C<$hash{$input}> as a scalar reference.
-
-=item An Array Reference
-
-If C<$output> is an array reference, the uncompressed data will be pushed
-onto the array.
-
-=back
-
-Any other type is a error.
=head2 Notes
When C<$input> maps to multiple files/buffers and C<$output> is a single
-file/buffer the uncompressed input files/buffers will all be stored in
-C<$output> as a single uncompressed stream.
+file/buffer the uncompressed input files/buffers will all be stored
+in C<$output> as a single uncompressed stream.
=item AutoClose =E<gt> 0|1
-This option applies to any input or output data streams to C<rawinflate>
-that are filehandles.
+This option applies to any input or output data streams to
+C<rawinflate> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<rawinflate> has
+=item BinModeOut =E<gt> 0|1
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+
+
+
+
=item -Append =E<gt> 0|1
TODO
+=item -MultiStream =E<gt> 0|1
+
+Creates a new stream after each file.
+
+Defaults to 1.
+
=back
Returns an C<IO::Uncompress::RawInflate> object on success and undef on failure.
The variable C<$RawInflateError> will contain an error message on failure.
-If you are running Perl 5.005 or better the object, C<$z>, returned from
-IO::Uncompress::RawInflate can be used exactly like an L<IO::File|IO::File> filehandle.
-This means that all normal input file operations can be carried out with C<$z>.
-For example, to read a line from a compressed file/buffer you can use either
-of these forms
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::RawInflate can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
$line = $z->getline();
$line = <$z>;
This option can be useful when the compressed data is embedded in another
file/data structure and it is not possible to work out where the compressed
-data begins without having to read the first few bytes. If this is the case,
-the uncompression can be I<primed> with these bytes using this option.
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
=item -Transparent =E<gt> 0|1
=item -BlockSize =E<gt> $num
-When reading the compressed input data, IO::Uncompress::RawInflate will read it in blocks
-of C<$num> bytes.
+When reading the compressed input data, IO::Uncompress::RawInflate will read it in
+blocks of C<$num> bytes.
This option defaults to 4096.
=item -InputLength =E<gt> $size
-When present this option will limit the number of compressed bytes read from
-the input file/buffer to C<$size>. This option can be used in the situation
-where there is useful data directly after the compressed data stream and you
-know beforehand the exact length of the compressed data stream.
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
-This option is mostly used when reading from a filehandle, in which case the
-file pointer will be left pointing to the first byte directly after the
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
compressed data stream.
This option controls what the C<read> method does with uncompressed data.
-If set to 1, all uncompressed data will be appended to the output parameter of
-the C<read> method.
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
-If set to 0, the contents of the output parameter of the C<read> method will be
-overwritten by the uncompressed data.
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
Defaults to 0.
Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
-writes any uncompressed data into C<$buffer>. If the C<Append> parameter is set
-in the constructor, the uncompressed data will be appended to the C<$buffer>
-parameter. Otherwise C<$buffer> will be overwritten.
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
-Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or
-a negative number on error.
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
=head2 read
Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
-The main difference between this form of the C<read> method and the previous
-one, is that this one will attempt to return I<exactly> C<$length> bytes. The
-only circumstances that this function will not is if end-of-file or an IO error
-is encountered.
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
-Returns the number of uncompressed bytes written to C<$buffer>, zero if eof or
-a negative number on error.
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
=head2 getline
Usage is
- $hdr = $z->getHeaderInfo()
-
-TODO
-
-
-
-
-
-
-
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
--- /dev/null
+package IO::Uncompress::Unzip;
+
+require 5.004 ;
+
+# for RFC1952
+
+use strict ;
+use warnings;
+
+use IO::Uncompress::RawInflate ;
+use Compress::Zlib::Common qw(createSelfTiedObject);
+use UncompressPlugin::Identity;
+
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError);
+
+$VERSION = '2.000_05';
+$UnzipError = '';
+
+@ISA = qw(Exporter IO::Uncompress::RawInflate);
+@EXPORT_OK = qw( $UnzipError unzip );
+%EXPORT_TAGS = %IO::Uncompress::RawInflate::EXPORT_TAGS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+
+sub new
+{
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$UnzipError);
+ $obj->_create(undef, 0, @_);
+}
+
+sub unzip
+{
+ my $obj = createSelfTiedObject(undef, \$UnzipError);
+ return $obj->_inf(@_) ;
+}
+
+sub getExtraParams
+{
+ use Compress::Zlib::ParseParameters;
+
+
+ return (
+# # Zip header fields
+ 'Name' => [1, 1, Parse_any, undef],
+
+# 'Streaming' => [1, 1, Parse_boolean, 1],
+ );
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # unzip always needs crc32
+ $got->value('CRC32' => 1);
+
+ *$self->{UnzipData}{Name} = $got->value('Name');
+
+ return 1;
+}
+
+
+sub ckMagic
+{
+ my $self = shift;
+
+ my $magic ;
+ $self->smartReadExact(\$magic, 4);
+
+ *$self->{HeaderPending} = $magic ;
+
+ return $self->HeaderError("Minimum header size is " .
+ 4 . " bytes")
+ if length $magic != 4 ;
+
+ return $self->HeaderError("Bad Magic")
+ if ! _isZipMagic($magic) ;
+
+ *$self->{Type} = 'zip';
+
+ return $magic ;
+}
+
+
+
+sub readHeader
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ my $name = *$self->{UnzipData}{Name} ;
+ my $status = $self->_readZipHeader($magic) ;
+
+ while (defined $status)
+ {
+ if (! defined $name || $status->{Name} eq $name)
+ {
+ return $status ;
+ }
+
+ # skip the data
+ my $c = $status->{CompressedLength};
+ my $buffer;
+ $self->smartReadExact(\$buffer, $c)
+ or return $self->saveErrorString(undef, "Truncated file");
+
+ # skip the trailer
+ $c = $status->{TrailerLength};
+ $self->smartReadExact(\$buffer, $c)
+ or return $self->saveErrorString(undef, "Truncated file");
+
+ $self->chkTrailer($buffer)
+ or return $self->saveErrorString(undef, "Truncated file");
+
+ $status = $self->_readFullZipHeader();
+
+ return $self->saveErrorString(undef, "Cannot find '$name'")
+ if $self->smartEof();
+ }
+
+ return undef;
+}
+
+sub chkTrailer
+{
+ my $self = shift;
+ my $trailer = shift;
+
+ my ($sig, $CRC32, $cSize, $uSize) ;
+ if (*$self->{ZipData}{Streaming}) {
+ ($sig, $CRC32, $cSize, $uSize) = unpack("V V V V", $trailer) ;
+ return $self->TrailerError("Data Descriptor signature")
+ if $sig != 0x08074b50;
+ }
+ else {
+ ($CRC32, $cSize, $uSize) =
+ (*$self->{ZipData}{Crc32},
+ *$self->{ZipData}{CompressedLen},
+ *$self->{ZipData}{UnCompressedLen});
+ }
+
+ if (*$self->{Strict}) {
+ #return $self->TrailerError("CRC mismatch")
+ # if $CRC32 != *$self->{Uncomp}->crc32() ;
+
+ my $exp_isize = *$self->{Uncomp}->compressedBytes();
+ return $self->TrailerError("CSIZE mismatch. Got $cSize"
+ . ", expected $exp_isize")
+ if $cSize != $exp_isize ;
+
+ $exp_isize = *$self->{Uncomp}->uncompressedBytes();
+ return $self->TrailerError("USIZE mismatch. Got $uSize"
+ . ", expected $exp_isize")
+ if $uSize != $exp_isize ;
+ }
+
+ # check for central directory or end of central directory
+ while (1)
+ {
+ my $magic ;
+ $self->smartReadExact(\$magic, 4);
+ my $sig = unpack("V", $magic) ;
+
+ if ($sig == 0x02014b50)
+ {
+ $self->skipCentralDirectory($magic);
+ }
+ elsif ($sig == 0x06054b50)
+ {
+ $self->skipEndCentralDirectory($magic);
+ last;
+ }
+ else
+ {
+ # put the data back
+ $self->pushBack($magic) ;
+ last;
+ }
+ }
+
+ return 1 ;
+}
+
+sub skipCentralDirectory
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ my $buffer;
+ $self->smartReadExact(\$buffer, 46 - 4)
+ or return $self->HeaderError("Minimum header size is " .
+ 46 . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+ *$self->{HeaderPending} = $keep ;
+
+ #my $versionMadeBy = unpack ("v", substr($buffer, 4-4, 2));
+ #my $extractVersion = unpack ("v", substr($buffer, 6-4, 2));
+ #my $gpFlag = unpack ("v", substr($buffer, 8-4, 2));
+ #my $compressedMethod = unpack ("v", substr($buffer, 10-4, 2));
+ #my $lastModTime = unpack ("V", substr($buffer, 12-4, 4));
+ #my $crc32 = unpack ("V", substr($buffer, 16-4, 4));
+ #my $compressedLength = unpack ("V", substr($buffer, 20-4, 4));
+ #my $uncompressedLength = unpack ("V", substr($buffer, 24-4, 4));
+ my $filename_length = unpack ("v", substr($buffer, 28-4, 2));
+ my $extra_length = unpack ("v", substr($buffer, 30-4, 2));
+ my $comment_length = unpack ("v", substr($buffer, 32-4, 2));
+ #my $disk_start = unpack ("v", substr($buffer, 34-4, 2));
+ #my $int_file_attrib = unpack ("v", substr($buffer, 36-4, 2));
+ #my $ext_file_attrib = unpack ("V", substr($buffer, 38-4, 2));
+ #my $lcl_hdr_offset = unpack ("V", substr($buffer, 42-4, 2));
+
+
+ my $filename;
+ my $extraField;
+ my $comment ;
+ if ($filename_length)
+ {
+ $self->smartReadExact(\$filename, $filename_length)
+ or return $self->HeaderError("xxx");
+ $keep .= $filename ;
+ }
+
+ if ($extra_length)
+ {
+ $self->smartReadExact(\$extraField, $extra_length)
+ or return $self->HeaderError("xxx");
+ $keep .= $extraField ;
+ }
+
+ if ($comment_length)
+ {
+ $self->smartReadExact(\$comment, $comment_length)
+ or return $self->HeaderError("xxx");
+ $keep .= $comment ;
+ }
+
+ return 1 ;
+}
+
+sub skipEndCentralDirectory
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ my $buffer;
+ $self->smartReadExact(\$buffer, 22 - 4)
+ or return $self->HeaderError("Minimum header size is " .
+ 22 . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+ *$self->{HeaderPending} = $keep ;
+
+ #my $diskNumber = unpack ("v", substr($buffer, 4-4, 2));
+ #my $cntrlDirDiskNo = unpack ("v", substr($buffer, 6-4, 2));
+ #my $entriesInThisCD = unpack ("v", substr($buffer, 8-4, 2));
+ #my $entriesInCD = unpack ("v", substr($buffer, 10-4, 2));
+ #my $sizeOfCD = unpack ("V", substr($buffer, 12-4, 2));
+ #my $offsetToCD = unpack ("V", substr($buffer, 16-4, 2));
+ my $comment_length = unpack ("v", substr($buffer, 20-4, 2));
+
+
+ my $comment ;
+ if ($comment_length)
+ {
+ $self->smartReadExact(\$comment, $comment_length)
+ or return $self->HeaderError("xxx");
+ $keep .= $comment ;
+ }
+
+ return 1 ;
+}
+
+
+
+
+sub _isZipMagic
+{
+ my $buffer = shift ;
+ return 0 if length $buffer < 4 ;
+ my $sig = unpack("V", $buffer) ;
+ return $sig == 0x04034b50 ;
+}
+
+
+sub _readFullZipHeader($)
+{
+ my ($self) = @_ ;
+ my $magic = '' ;
+
+ $self->smartReadExact(\$magic, 4);
+
+ *$self->{HeaderPending} = $magic ;
+
+ return $self->HeaderError("Minimum header size is " .
+ 30 . " bytes")
+ if length $magic != 4 ;
+
+
+ return $self->HeaderError("Bad Magic")
+ if ! _isZipMagic($magic) ;
+
+ my $status = $self->_readZipHeader($magic);
+ delete *$self->{Transparent} if ! defined $status ;
+ return $status ;
+}
+
+sub _readZipHeader($)
+{
+ my ($self, $magic) = @_ ;
+ my ($HeaderCRC) ;
+ my ($buffer) = '' ;
+
+ $self->smartReadExact(\$buffer, 30 - 4)
+ or return $self->HeaderError("Minimum header size is " .
+ 30 . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+ *$self->{HeaderPending} = $keep ;
+
+ my $extractVersion = unpack ("v", substr($buffer, 4-4, 2));
+ my $gpFlag = unpack ("v", substr($buffer, 6-4, 2));
+ my $compressedMethod = unpack ("v", substr($buffer, 8-4, 2));
+ my $lastModTime = unpack ("V", substr($buffer, 10-4, 4));
+ my $crc32 = unpack ("V", substr($buffer, 14-4, 4));
+ my $compressedLength = unpack ("V", substr($buffer, 18-4, 4));
+ my $uncompressedLength = unpack ("V", substr($buffer, 22-4, 4));
+ my $filename_length = unpack ("v", substr($buffer, 26-4, 2));
+ my $extra_length = unpack ("v", substr($buffer, 28-4, 2));
+
+ my $filename;
+ my $extraField;
+ my $streamingMode = ($gpFlag & 0x08) ? 1 : 0 ;
+
+ return $self->HeaderError("Streamed Stored content not supported")
+ if $streamingMode && $compressedMethod == 0 ;
+
+ *$self->{ZipData}{Streaming} = $streamingMode;
+
+ if (! $streamingMode) {
+ *$self->{ZipData}{Streaming} = 0;
+ *$self->{ZipData}{Crc32} = $crc32;
+ *$self->{ZipData}{CompressedLen} = $compressedLength;
+ *$self->{ZipData}{UnCompressedLen} = $uncompressedLength;
+ }
+
+ if ($filename_length)
+ {
+ $self->smartReadExact(\$filename, $filename_length)
+ or return $self->HeaderError("xxx");
+ $keep .= $filename ;
+ }
+
+ if ($extra_length)
+ {
+ $self->smartReadExact(\$extraField, $extra_length)
+ or return $self->HeaderError("xxx");
+ $keep .= $extraField ;
+ }
+
+ *$self->{CompressedInputLengthRemaining} =
+ *$self->{CompressedInputLength} = $compressedLength;
+
+ if ($compressedMethod == 8)
+ {
+ *$self->{Type} = 'zip';
+ }
+ elsif ($compressedMethod == 0)
+ {
+ # TODO -- add support for reading uncompressed
+
+ *$self->{Type} = 'zipStored';
+
+ my $obj = UncompressPlugin::Identity::mkUncompObject(# $got->value('CRC32'),
+ # $got->value('ADLER32'),
+ );
+
+ *$self->{Uncomp} = $obj;
+
+ }
+ else
+ {
+ return $self->HeaderError("Unsupported Compression format $compressedMethod");
+ }
+
+ return {
+ 'Type' => 'zip',
+ 'FingerprintLength' => 2,
+ #'HeaderLength' => $compressedMethod == 8 ? length $keep : 0,
+ 'HeaderLength' => length $keep,
+ 'TrailerLength' => $streamingMode ? 16 : 0,
+ 'Header' => $keep,
+ 'CompressedLength' => $compressedLength ,
+ 'UncompressedLength' => $uncompressedLength ,
+ 'CRC32' => $crc32 ,
+ 'Name' => $filename,
+ 'Time' => _dosToUnixTime($lastModTime),
+ 'Stream' => $streamingMode,
+
+ 'MethodID' => $compressedMethod,
+ 'MethodName' => $compressedMethod == 8
+ ? "Deflated"
+ : $compressedMethod == 0
+ ? "Stored"
+ : "Unknown" ,
+
+# 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0,
+# 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0,
+# 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0,
+# 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0,
+# 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0,
+# 'Comment' => $comment,
+# 'OsID' => $os,
+# 'OsName' => defined $GZIP_OS_Names{$os}
+# ? $GZIP_OS_Names{$os} : "Unknown",
+# 'HeaderCRC' => $HeaderCRC,
+# 'Flags' => $flag,
+# 'ExtraFlags' => $xfl,
+# 'ExtraFieldRaw' => $EXTRA,
+# 'ExtraField' => [ @EXTRA ],
+
+
+ }
+}
+
+# from Archive::Zip
+sub _dosToUnixTime
+{
+ #use Time::Local 'timelocal_nocheck';
+ use Time::Local 'timelocal';
+
+ my $dt = shift;
+
+ my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
+ my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1;
+ my $mday = ( ( $dt >> 16 ) & 0x1f );
+
+ my $hour = ( ( $dt >> 11 ) & 0x1f );
+ my $min = ( ( $dt >> 5 ) & 0x3f );
+ my $sec = ( ( $dt << 1 ) & 0x3e );
+
+ # catch errors
+ my $time_t =
+ eval { timelocal( $sec, $min, $hour, $mday, $mon, $year ); };
+ return 0
+ if $@;
+ return $time_t;
+}
+
+
+1;
+
+__END__
+
--- /dev/null
+package UncompressPlugin::Identity;
+
+use warnings;
+use strict;
+
+use Compress::Zlib::Common qw(:Status);
+
+our ($VERSION);
+
+$VERSION = '2.000_05';
+
+use Compress::Zlib ();
+
+sub mkUncompObject
+{
+ my $crc32 = 1; #shift ;
+ my $adler32 = shift;
+
+ bless { 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'wantCRC32' => $crc32,
+ 'CRC32' => Compress::Zlib::crc32(''),
+ 'wantADLER32'=> $adler32,
+ 'ADLER32' => Compress::Zlib::adler32(''),
+ } ;
+}
+
+sub uncompr
+{
+ my $self = shift;
+ my $eof = $_[2];
+
+ if (defined ${ $_[0] } && length ${ $_[0] }) {
+ $self->{CompSize} += length ${ $_[0] } ;
+ $self->{UnCompSize} = $self->{CompSize} ;
+
+ $self->{CRC32} = Compress::Zlib::crc32($_[0], $self->{CRC32})
+ if $self->{wantCRC32};
+
+ $self->{ADLER32} = Compress::Zlib::adler32($_[0], $self->{ADLER32})
+ if $self->{wantADLER32};
+
+ ${ $_[1] } .= ${ $_[0] };
+ }
+
+ return STATUS_ENDSTREAM if $eof;
+ return STATUS_OK ;
+}
+
+sub reset
+{
+ return STATUS_OK ;
+}
+
+
+sub count
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub compressedBytes
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub sync
+{
+ return STATUS_OK ;
+}
+
+sub crc32
+{
+ my $self = shift ;
+ return $self->{CRC32};
+}
+
+sub adler32
+{
+ my $self = shift ;
+ return $self->{ADLER32};
+}
+
+1;
+
+__END__
--- /dev/null
+package UncompressPlugin::Inflate;
+
+use strict;
+use warnings;
+
+use Compress::Zlib::Common qw(:Status);
+use Compress::Zlib qw(Z_OK Z_DATA_ERROR Z_STREAM_END Z_FINISH MAX_WBITS);
+
+our ($VERSION);
+$VERSION = '2.000_05';
+
+
+
+sub mkUncompObject
+{
+ my $crc32 = shift || 1;
+ my $adler32 = shift || 1;
+ my $scan = shift || 0;
+
+ my $inflate ;
+ my $status ;
+
+ if ($scan)
+ {
+ ($inflate, $status) = new Compress::Zlib::InflateScan
+ CRC32 => $crc32,
+ ADLER32 => $adler32,
+ WindowBits => - MAX_WBITS ;
+ }
+ else
+ {
+ ($inflate, $status) = new Compress::Zlib::Inflate
+ AppendOutput => 1,
+ CRC32 => $crc32,
+ ADLER32 => $adler32,
+ WindowBits => - MAX_WBITS ;
+ }
+
+ return (undef, "Could not create Inflation object: $status", $status)
+ if $status != Z_OK ;
+
+ return bless {'Inf' => $inflate,
+ 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'Error' => '',
+ } ;
+
+}
+
+sub uncompr
+{
+ my $self = shift ;
+ my $from = shift ;
+ my $to = shift ;
+ my $eof = shift ;
+
+ my $inf = $self->{Inf};
+
+ my $status = $inf->inflate($from, $to, $eof);
+ $self->{ErrorNo} = $status;
+
+ if ($status != Z_STREAM_END && $eof)
+ {
+ $self->{Error} = "unexpected end of file";
+ return STATUS_ERROR;
+ }
+
+ if ($status != Z_OK && $status != Z_STREAM_END )
+ {
+ $self->{Error} = "Inflation Error: $status";
+ return STATUS_ERROR;
+ }
+
+
+ return STATUS_OK if $status == Z_OK ;
+ return STATUS_ENDSTREAM if $status == Z_STREAM_END ;
+ return STATUS_ERROR ;
+}
+
+sub reset
+{
+ my $self = shift ;
+ $self->{Inf}->inflateReset();
+
+ return STATUS_OK ;
+}
+
+sub count
+{
+ my $self = shift ;
+ $self->{Inf}->inflateCount();
+}
+
+sub crc32
+{
+ my $self = shift ;
+ $self->{Inf}->crc32();
+}
+
+sub compressedBytes
+{
+ my $self = shift ;
+ $self->{Inf}->compressedBytes();
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ $self->{Inf}->uncompressedBytes();
+}
+
+sub adler32
+{
+ my $self = shift ;
+ $self->{Inf}->adler32();
+}
+
+sub sync
+{
+ my $self = shift ;
+ ( $self->{Inf}->inflateSync(@_) == Z_OK)
+ ? STATUS_OK
+ : STATUS_ERROR ;
+}
+
+
+sub getLastBlockOffset
+{
+ my $self = shift ;
+ $self->{Inf}->getLastBlockOffset();
+}
+
+sub getEndOffset
+{
+ my $self = shift ;
+ $self->{Inf}->getEndOffset();
+}
+
+sub resetLastBlockByte
+{
+ my $self = shift ;
+ $self->{Inf}->resetLastBlockByte(@_);
+}
+
+sub createDeflateStream
+{
+ my $self = shift ;
+ my $deflate = $self->{Inf}->createDeflateStream(@_);
+ return bless {'Def' => $deflate,
+ 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'Error' => '',
+ }, 'CompressPlugin::Deflate';
+}
+
+1;
+
+
+__END__
+
=head2 Compatibility with Unix compress/uncompress.
-Although C<Compress::Zlib> has a pair of functions called C<compress>
-and C<uncompress>, they are I<not> the same as the Unix programs of the
-same name. The C<Compress::Zlib> library is not compatible with Unix
+Although C<Compress::Zlib> has a pair of functions called C<compress> and
+C<uncompress>, they are I<not> the same as the Unix programs of the same
+name. The C<Compress::Zlib> library is not compatible with Unix
C<compress>.
-If you have the C<uncompress> program available, you can use this to
-read compressed files
+If you have the C<uncompress> program available, you can use this to read
+compressed files
open F, "uncompress -c $filename |";
while (<F>)
{
...
-If you have the C<gunzip> program available, you can use this to read
-compressed files
+Alternatively, if you have the C<gunzip> program available, you can use
+this to read compressed files
open F, "gunzip -c $filename |";
while (<F>)
=head2 Accessing .tar.Z files
-The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via
-the C<IO::Zlib> module) to access tar files that have been compressed
-with C<gzip>. Unfortunately tar files compressed with the Unix C<compress>
+The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via the
+C<IO::Zlib> module) to access tar files that have been compressed with
+C<gzip>. Unfortunately tar files compressed with the Unix C<compress>
utility cannot be read by C<Compress::Zlib> and so cannot be directly
accesses by C<Archive::Tar>.
-If the C<uncompress> or C<gunzip> programs are available, you can use
-one of these workarounds to read C<.tar.Z> files from C<Archive::Tar>
+If the C<uncompress> or C<gunzip> programs are available, you can use one
+of these workarounds to read C<.tar.Z> files from C<Archive::Tar>
Firstly with C<uncompress>
=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
=item 1.
-When calling B<inflateInit> or B<deflateInit> the B<WindowBits> parameter
-must be set to C<-MAX_WBITS>. This disables the creation of the zlib
-header.
+When calling B<Compress::Zlib::Inflate::new> or
+B<Compress::Zlib::Deflate::new> the B<WindowBits> parameter must be set to
+C<-MAX_WBITS>. This enables the creation of an RFC1951 compressed data
+stream.
=item 2.
+If you are using zlib older than 1.2.0,
The zlib function B<inflate>, and so the B<inflate> method supplied in
this module, assume that there is at least one trailing byte after the
compressed data stream. Normally this isn't a problem because both
=head2 Zlib Library Version Support
-By default C<Compress::Zlib> will build with a private copy of version 1.2.3 of the zlib library. (See the F<README> file for details of how
-to override this behavior)
+By default C<Compress::Zlib> will build with a private copy of version
+1.2.3 of the zlib library. (See the F<README> file for details of
+how to override this behaviour)
If you decide to use a different version of the zlib library, you need to be
aware of the following issues
=item *
-You need to have zlib 1.2.1 or better if you want to use the C<-Merge> option
-with C<IO::Compress::Gzip>, C<IO::Compress::Deflate> and C<IO::Compress::RawDeflate>.
+You need to have zlib 1.2.1 or better if you want to use the C<-Merge>
+option with C<IO::Compress::Gzip>, C<IO::Compress::Deflate> and
+C<IO::Compress::RawDeflate>.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2006 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
/*
----------------------------------------------------------------------
- ppport.h -- Perl/Pollution/Portability Version 3.02
+ ppport.h -- Perl/Pollution/Portability Version 3.06
Automatically created by Devel::PPPort running under
- perl 5.009002 on Wed Sep 8 21:34:54 2004.
+ perl 5.009003 on Mon Jan 9 10:21:52 2006.
Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
includes in parts/inc/ instead.
=head1 NAME
-ppport.h - Perl/Pollution/Portability version 3.02
+ppport.h - Perl/Pollution/Portability version 3.06
=head1 SYNOPSIS
--list-provided list provided API
--list-unsupported list unsupported API
+ --api-info=name show Perl API portability information
=head1 COMPATIBILITY
F<ppport.h> and below which version of Perl they probably
won't be available or work.
+=head2 --api-info=I<name>
+
+Show portability information for API elements matching I<name>.
+If I<name> is surrounded by slashes, it is interpreted as a regular
+expression.
+
=head1 DESCRIPTION
In order for a Perl extension (XS) module to be as portable as possible
This would output context diffs with 10 lines of context.
+To display portability information for the C<newSVpvn> function,
+use:
+
+ perl ppport.h --api-info=newSVpvn
+
+Since the argument to C<--api-info> can be a regular expression,
+you can use
+
+ perl ppport.h --api-info=/_nomg$/
+
+to display portability information for all C<_nomg> functions or
+
+ perl ppport.h --api-info=/./
+
+to display information for all known API elements.
+
=head1 BUGS
If this version of F<ppport.h> is causing failure during
=head1 COPYRIGHT
-Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz.
+Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz.
Version 2.x, Copyright (C) 2001, Paul Marquess.
Getopt::Long::GetOptions(\%opt, qw(
help quiet diag! hints! changes! cplusplus
patch=s copy=s diff=s compat-version=s
- list-provided list-unsupported
+ list-provided list-unsupported api-info=s
)) or usage();
};
UVof|5.006000||p
UVuf|5.006000||p
UVxf|5.006000||p
+XCPT_CATCH|5.009002||p
+XCPT_RETHROW|5.009002||p
+XCPT_TRY_END|5.009002||p
+XCPT_TRY_START|5.009002||p
XPUSHi|||
XPUSHmortal|5.009002||p
XPUSHn|||
dTHXoa|5.006000||p
dTHX|5.006000||p
dUNDERBAR|5.009002||p
+dXCPT|5.009002||p
dXSARGS|||
dXSI32|||
+dXSTARG|5.006000||p
deb_curcv|||
deb_nocontext|||vn
deb_stack_all|||
debstackptrs||5.007003|
debstack||5.007003|
deb||5.007003|v
-default_protect|||v
del_he|||
del_sv|||
del_xiv|||
gv_fetchmethod_autoload||5.004000|
gv_fetchmethod|||
gv_fetchmeth|||
+gv_fetchpvn_flags||5.009002|
gv_fetchpv|||
+gv_fetchsv||5.009002|
gv_fullname3||5.004000|
gv_fullname4||5.006001|
gv_fullname|||
isSPACE|||
isUPPER|||
is_an_int|||
+is_gv_magical_sv|||
is_gv_magical|||
is_handle_constructor|||
is_lvalue_sub||5.007001|
op_dump||5.006000|
op_free|||
op_null||5.007002|
+op_refcnt_lock||5.009002|
+op_refcnt_unlock||5.009002|
open_script|||
pMY_CXT_|5.007003||p
pMY_CXT|5.007003||p
savesharedpv||5.007003|
savestack_grow_cnt||5.008001|
savestack_grow|||
+savesvpv||5.009002|
sawparens|||
scalar_mod_type|||
scalarboolean|||
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|||
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|
$need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
}
+if (exists $opt{'api-info'}) {
+ my $f;
+ my $count = 0;
+ my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $f =~ /$match/;
+ print "\n=== $f ===\n\n";
+ my $info = 0;
+ if ($API{$f}{base} || $API{$f}{todo}) {
+ my $base = format_version($API{$f}{base} || $API{$f}{todo});
+ print "Supported at least starting from perl-$base.\n";
+ $info++;
+ }
+ if ($API{$f}{provided}) {
+ my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
+ print "Support by $ppport provided back to perl-$todo.\n";
+ print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
+ print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
+ print "$hints{$f}" if exists $hints{$f};
+ $info++;
+ }
+ unless ($info) {
+ print "No portability information available.\n";
+ }
+ $count++;
+ }
+ if ($count > 0) {
+ print "\n";
+ }
+ else {
+ print "Found no API matching '$opt{'api-info'}'.\n";
+ }
+ exit 0;
+}
+
if (exists $opt{'list-provided'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
/* Replace: 0 */
#endif
-#ifdef HASATTRIBUTE
-# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
-# define PERL_UNUSED_DECL
+#ifndef PERL_UNUSED_DECL
+# ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
# else
-# define PERL_UNUSED_DECL __attribute__((unused))
+# define PERL_UNUSED_DECL
# endif
-#else
-# define PERL_UNUSED_DECL
#endif
#ifndef NOOP
# define NOOP (void)0
#ifndef dITEMS
# define dITEMS I32 items = SP - MARK
#endif
+#ifndef dXSTARG
+# define dXSTARG SV * targ = sv_newmortal()
+#endif
#ifndef dTHR
# define dTHR dNOOP
#endif
#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
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+#ifndef START_MY_CXT
+
/* This must appear in all extensions that define a my_cxt_t structure,
* right after the definition (i.e. at file scope). The non-threads
* case below uses it to declare the data as static. */
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)
#define aMY_CXT_ aMY_CXT,
#define _aMY_CXT ,aMY_CXT
+#endif /* START_MY_CXT */
+
+#ifndef MY_CXT_CLONE
+/* Clones the per-interpreter data. */
+#define MY_CXT_CLONE \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+#endif
+
#else /* single interpreter */
+#ifndef START_MY_CXT
+
#define START_MY_CXT static my_cxt_t my_cxt;
#define dMY_CXT_SV dNOOP
#define dMY_CXT dNOOP
#define MY_CXT_INIT NOOP
-#define MY_CXT_CLONE NOOP
#define MY_CXT my_cxt
#define pMY_CXT void
#define aMY_CXT_
#define _aMY_CXT
-#endif
-
#endif /* START_MY_CXT */
+#ifndef MY_CXT_CLONE
+#define MY_CXT_CLONE NOOP
+#endif
+
+#endif
+
#ifndef IVdf
# if IVSIZE == LONGSIZE
# define IVdf "ld"
#ifndef SvPV_nolen
-/* #if defined(NEED_sv_2pv_nolen) */
-#if 1
+#if defined(NEED_sv_2pv_nolen)
static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
static
#else
#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a)
#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen)
-/* #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) */
-#if 1
+#if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
char *
DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv)
# define sv_pvn(sv, len) SvPV(sv, len)
#endif
-/* Hint: sv_pvn
+/* Hint: sv_pvn_force
* Always use the SvPV_force() macro instead of sv_pvn_force().
*/
#ifndef sv_pvn_force
#endif
#endif
+#ifdef NO_XSLOCKS
+# ifdef dJMPENV
+# define dXCPT dJMPENV; int rEtV = 0
+# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
+# define XCPT_TRY_END JMPENV_POP;
+# define XCPT_CATCH if (rEtV != 0)
+# define XCPT_RETHROW JMPENV_JUMP(rEtV)
+# else
+# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
+# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
+# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
+# define XCPT_CATCH if (rEtV != 0)
+# define XCPT_RETHROW Siglongjmp(top_env, rEtV)
+# endif
+#endif
+
#endif /* _P_P_PORTABILITY_H_ */
/* End of File ppport.h */
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = ("../lib", "lib");
- }
-}
-
-use lib 't';
-use strict;
-use warnings;
-use bytes;
-
-use Test::More ;
-use ZlibTestUtils;
-
-BEGIN
-{
- # use Test::NoWarnings, if available
- my $extra = 0 ;
- $extra = 1
- if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
-
- plan tests => 1769 + $extra ;
-
- use_ok('Compress::Zlib', 2) ;
-
- use_ok('IO::Compress::Gzip', qw($GzipError)) ;
- use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
-
- use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
- use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
-
- use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
- use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
-
-}
-
-use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
-
-
-our ($UncompressClass);
-
-
-sub myGZreadFile
-{
- my $filename = shift ;
- my $init = shift ;
-
-
- my $fil = new $UncompressClass $filename,
- -Strict => 1,
- -Append => 1
- ;
-
- my $data = '';
- $data = $init if defined $init ;
- 1 while $fil->read($data) > 0;
-
- $fil->close ;
- return $data ;
-}
-
-# Check zlib_version and ZLIB_VERSION are the same.
-is Compress::Zlib::zlib_version, ZLIB_VERSION,
- "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
-
-
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate')
-{
-
- title "Testing $CompressClass";
-
- # Buffer not writable
- eval qq[\$a = new $CompressClass(\\1) ;] ;
- like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ;
-
- my $out = "" ;
- eval qq[\$a = new $CompressClass \$out ;] ;
- like $@, mkEvalErr("^$CompressClass: output filename is undef or null string");
-
- $out = undef ;
- eval qq[\$a = new $CompressClass \$out ;] ;
- like $@, mkEvalErr("^$CompressClass: output filename is undef or null string");
-
- my $x ;
- my $gz = new $CompressClass(\$x);
-
- foreach my $name (qw(read readline getc))
- {
- eval " \$gz->$name() " ;
- like $@, mkEvalErr("^$name Not Available: File opened only for output");
- }
-
- eval ' $gz->write({})' ;
- like $@, mkEvalErr("^${CompressClass}::write: not a scalar reference");
- #like $@, mkEvalErr("^${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref");
-
- eval ' $gz->syswrite("abc", 1, 5)' ;
- like $@, mkEvalErr("^${CompressClass}::write: offset outside string");
-
- eval ' $gz->syswrite("abc", 1, -4)' ;
- like $@, mkEvalErr("^${CompressClass}::write: offset outside string");
-}
-
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- $UncompressClass = getInverse($CompressClass);
- my $Error = getErrorRef($CompressClass);
- my $UnError = getErrorRef($UncompressClass);
-
- title "Testing $UncompressClass";
-
- my $out = "" ;
- eval qq[\$a = new $UncompressClass \$out ;] ;
- like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string");
-
- $out = undef ;
- eval qq[\$a = new $UncompressClass \$out ;] ;
- like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string");
-
- my $lex = new LexFile my $name ;
-
- ok ! -e $name, " $name does not exist";
-
- eval qq[\$a = new $UncompressClass "$name" ;] ;
- is $$UnError, "input file '$name' does not exist";
-
- my $gc ;
- my $guz = new $CompressClass(\$gc);
- $guz->write("abc") ;
- $guz->close();
-
- my $x ;
- my $gz = new $UncompressClass(\$gc);
-
- foreach my $name (qw(print printf write))
- {
- eval " \$gz->$name() " ;
- like $@, mkEvalErr("^$name Not Available: File opened only for intput");
- }
-
-}
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- $UncompressClass = getInverse($CompressClass);
- my $Error = getErrorRef($CompressClass);
- my $ErrorUnc = getErrorRef($UncompressClass);
-
-
- title "Testing $CompressClass and $UncompressClass";
-
- {
- my ($a, $x, @x) = ("","","") ;
-
- # Buffer not a scalar reference
- eval qq[\$a = new $CompressClass \\\@x ;] ;
- like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref");
-
- # Buffer not a scalar reference
- eval qq[\$a = new $UncompressClass \\\@x ;] ;
- like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref");
- }
-
- foreach my $Type ( $CompressClass, $UncompressClass)
- {
- # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate
-
- my ($a, $x, @x) = ("","","") ;
-
- # Odd number of parameters
- eval qq[\$a = new $Type "abc", -Output ] ;
- like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1");
-
- # Unknown parameter
- eval qq[\$a = new $Type "anc", -Fred => 123 ;] ;
- like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred");
-
- # no in or out param
- eval qq[\$a = new $Type ;] ;
- like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter");
-
- }
-
-
- {
- # write a very simple compressed file
- # and read back
- #========================================
-
-
- my $lex = new LexFile my $name ;
-
- my $hello = <<EOM ;
-hello world
-this is a test
-EOM
-
- {
- my $x ;
- ok $x = new $CompressClass $name ;
-
- ok $x->write($hello), "write" ;
- ok $x->flush(Z_FINISH), "flush";
- ok $x->close, "close" ;
- }
-
- {
- my $uncomp;
- ok my $x = new $UncompressClass $name, -Append => 1 ;
-
- my $len ;
- 1 while ($len = $x->read($uncomp)) > 0 ;
-
- is $len, 0, "read returned 0";
-
- ok $x->close ;
- is $uncomp, $hello ;
- }
- }
-
- {
- # write a very simple compressed file
- # and read back
- #========================================
-
-
- my $lex = new LexFile my $name ;
-
- my $hello = <<EOM ;
-hello world
-this is a test
-EOM
-
- {
- my $x ;
- ok $x = new $CompressClass $name ;
-
- is $x->write(''), 0, "Write empty string is ok";
- is $x->write(undef), 0, "Write undef is ok";
- ok $x->write($hello), "Write ok" ;
- ok $x->close, "Close ok" ;
- }
-
- {
- my $uncomp;
- my $x = new $UncompressClass $name ;
- ok $x, "creates $UncompressClass $name" ;
-
- my $data = '';
- $data .= $uncomp while $x->read($uncomp) > 0 ;
-
- ok $x->close, "close ok" ;
- is $data, $uncomp,"expected output" ;
- }
- }
-
-
- {
- # write a very simple file with using an IO filehandle
- # and read back
- #========================================
-
-
- my $lex = new LexFile my $name ;
-
- my $hello = <<EOM ;
-hello world
-this is a test
-EOM
-
- {
- my $fh = new IO::File ">$name" ;
- ok $fh, "opened file $name ok";
- my $x = new $CompressClass $fh ;
- ok $x, " created $CompressClass $fh" ;
-
- is $x->fileno(), fileno($fh), "fileno match" ;
- is $x->write(''), 0, "Write empty string is ok";
- is $x->write(undef), 0, "Write undef is ok";
- ok $x->write($hello), "write ok" ;
- ok $x->flush(), "flush";
- ok $x->close,"close" ;
- $fh->close() ;
- }
-
- my $uncomp;
- {
- my $x ;
- ok my $fh1 = new IO::File "<$name" ;
- ok $x = new $UncompressClass $fh1, -Append => 1 ;
- ok $x->fileno() == fileno $fh1 ;
-
- 1 while $x->read($uncomp) > 0 ;
-
- ok $x->close ;
- }
-
- ok $hello eq $uncomp ;
- }
-
- {
- # write a very simple file with using a glob filehandle
- # and read back
- #========================================
-
-
- my $lex = new LexFile my $name ;
-
- my $hello = <<EOM ;
-hello world
-this is a test
-EOM
-
- {
- title "$CompressClass: Input from typeglob filehandle";
- ok open FH, ">$name" ;
-
- my $x = new $CompressClass *FH ;
- ok $x, " create $CompressClass" ;
-
- is $x->fileno(), fileno(*FH), " fileno" ;
- is $x->write(''), 0, " Write empty string is ok";
- is $x->write(undef), 0, " Write undef is ok";
- ok $x->write($hello), " Write ok" ;
- ok $x->flush(), " Flush";
- ok $x->close, " Close" ;
- close FH;
- }
-
- my $uncomp;
- {
- title "$UncompressClass: Input from typeglob filehandle, append output";
- my $x ;
- ok open FH, "<$name" ;
- ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0 ;
- is $x->fileno(), fileno FH, " fileno ok" ;
-
- 1 while $x->read($uncomp) > 0 ;
-
- ok $x->close, " close" ;
- }
-
- is $uncomp, $hello, " expected output" ;
- }
-
- {
- my $lex = new LexFile my $name ;
-
- my $hello = <<EOM ;
-hello world
-this is a test
-EOM
-
- {
- title "Outout to stdout via '-'" ;
-
- open(SAVEOUT, ">&STDOUT");
- my $dummy = fileno SAVEOUT;
- open STDOUT, ">$name" ;
-
- my $x = new $CompressClass '-' ;
- $x->write($hello);
- $x->close;
-
- open(STDOUT, ">&SAVEOUT");
-
- ok 1, " wrote to stdout" ;
- }
-
- {
- title "Input from stdin via filename '-'";
-
- my $x ;
- my $uncomp ;
- my $stdinFileno = fileno(STDIN);
- # open below doesn't return 1 sometines on XP
- open(SAVEIN, "<&STDIN");
- ok open(STDIN, "<$name"), " redirect STDIN";
- my $dummy = fileno SAVEIN;
- $x = new $UncompressClass '-';
- ok $x, " created object" ;
- is $x->fileno(), $stdinFileno, " fileno ok" ;
-
- 1 while $x->read($uncomp) > 0 ;
-
- ok $x->close, " close" ;
- open(STDIN, "<&SAVEIN");
- is $hello, $uncomp, " expected output" ;
- }
- }
-
- {
- # write a compressed file to memory
- # and read back
- #========================================
-
- my $name = "test.gz" ;
-
- my $hello = <<EOM ;
-hello world
-this is a test
-EOM
-
- my $buffer ;
- {
- my $x ;
- ok $x = new $CompressClass(\$buffer) ;
-
- ok ! defined $x->fileno() ;
- is $x->write(''), 0, "Write empty string is ok";
- is $x->write(undef), 0, "Write undef is ok";
- ok $x->write($hello) ;
- ok $x->flush();
- ok $x->close ;
-
- writeFile($name, $buffer) ;
- #is anyUncompress(\$buffer), $hello, " any ok";
- }
-
- my $keep = $buffer ;
- my $uncomp;
- {
- my $x ;
- ok $x = new $UncompressClass(\$buffer, Append => 1) ;
-
- ok ! defined $x->fileno() ;
- 1 while $x->read($uncomp) > 0 ;
-
- ok $x->close ;
- }
-
- is $uncomp, $hello ;
- ok $buffer eq $keep ;
- }
-
- if ($CompressClass ne 'RawDeflate')
- {
- # write empty file
- #========================================
-
- my $buffer = '';
- {
- my $x ;
- ok $x = new $CompressClass(\$buffer) ;
- ok $x->close ;
-
- }
-
- my $keep = $buffer ;
- my $uncomp= '';
- {
- my $x ;
- ok $x = new $UncompressClass(\$buffer, Append => 1) ;
-
- 1 while $x->read($uncomp) > 0 ;
-
- ok $x->close ;
- }
-
- ok $uncomp eq '' ;
- ok $buffer eq $keep ;
-
- }
-
- {
- # write a larger file
- #========================================
-
-
- my $lex = new LexFile my $name ;
-
- my $hello = <<EOM ;
-hello world
-this is a test
-EOM
-
- my $input = '' ;
- my $contents = '' ;
-
- {
- my $x = new $CompressClass $name ;
- ok $x, " created $CompressClass object";
-
- ok $x->write($hello), " write ok" ;
- $input .= $hello ;
- ok $x->write("another line"), " write ok" ;
- $input .= "another line" ;
- # all characters
- foreach (0 .. 255)
- { $contents .= chr int $_ }
- # generate a long random string
- foreach (1 .. 5000)
- { $contents .= chr int rand 256 }
-
- ok $x->write($contents), " write ok" ;
- $input .= $contents ;
- ok $x->close, " close ok" ;
- }
-
- ok myGZreadFile($name) eq $input ;
- my $x = readFile($name) ;
- #print "length " . length($x) . " \n";
- }
-
- {
- # embed a compressed file in another file
- #================================
-
-
- my $lex = new LexFile my $name ;
-
- my $hello = <<EOM ;
-hello world
-this is a test
-EOM
-
- my $header = "header info\n" ;
- my $trailer = "trailer data\n" ;
-
- {
- my $fh ;
- ok $fh = new IO::File ">$name" ;
- print $fh $header ;
- my $x ;
- ok $x = new $CompressClass $fh,
- -AutoClose => 0 ;
-
- ok $x->binmode();
- ok $x->write($hello) ;
- ok $x->close ;
- print $fh $trailer ;
- $fh->close() ;
- }
-
- my ($fil, $uncomp) ;
- my $fh1 ;
- ok $fh1 = new IO::File "<$name" ;
- # skip leading junk
- my $line = <$fh1> ;
- ok $line eq $header ;
-
- ok my $x = new $UncompressClass $fh1 ;
- ok $x->binmode();
- my $got = $x->read($uncomp);
-
- ok $uncomp eq $hello ;
- my $rest ;
- read($fh1, $rest, 5000);
- is ${ $x->trailingData() } . $rest, $trailer ;
- #print ${ $x->trailingData() } . $rest ;
-
- }
-
- {
- # Write
- # these tests come almost 100% from IO::String
-
- my $lex = new LexFile my $name ;
-
- my $io = $CompressClass->new($name);
-
- is $io->tell(), 0, " tell returns 0"; ;
-
- my $heisan = "Heisan\n";
- $io->print($heisan) ;
-
- ok ! $io->eof(), " ! eof";
-
- is $io->tell(), length($heisan), " tell is " . length($heisan) ;
-
- $io->print("a", "b", "c");
-
- {
- local($\) = "\n";
- $io->print("d", "e");
- local($,) = ",";
- $io->print("f", "g", "h");
- }
-
- {
- local($\) ;
- $io->print("D", "E");
- local($,) = ".";
- $io->print("F", "G", "H");
- }
-
- my $foo = "1234567890";
-
- is $io->syswrite($foo, length($foo)), length($foo), " syswrite ok" ;
- if ( $[ < 5.6 )
- { is $io->syswrite($foo, length $foo), length $foo, " syswrite ok" }
- else
- { is $io->syswrite($foo), length $foo, " syswrite ok" }
- is $io->syswrite($foo, length($foo)), length $foo, " syswrite ok";
- is $io->write($foo, length($foo), 5), 5, " write 5";
- is $io->write("xxx\n", 100, -1), 1, " write 1";
-
- for (1..3) {
- $io->printf("i(%d)", $_);
- $io->printf("[%d]\n", $_);
- }
- $io->print("\n");
-
- $io->close ;
-
- ok $io->eof(), " eof";
-
- is myGZreadFile($name), "Heisan\nabcde\nf,g,h\nDEF.G.H" .
- ("1234567890" x 3) . "67890\n" .
- "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
-
-
- }
-
- {
- # Read
- my $str = <<EOT;
-This is an example
-of a paragraph
-
-
-and a single line.
-
-EOT
-
- my $lex = new LexFile my $name ;
-
- my %opts = () ;
- %opts = (CRC32 => 1, Adler32 => 1)
- if $CompressClass ne "IO::Compress::Gzip";
- my $iow = new $CompressClass $name, %opts;
- $iow->print($str) ;
- $iow->close ;
-
- my @tmp;
- my $buf;
- {
- my $io = new $UncompressClass $name ;
-
- ok ! $io->eof;
- is $io->tell(), 0 ;
- #my @lines = <$io>;
- my @lines = $io->getlines();
- is @lines, 6
- or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
- is $lines[1], "of a paragraph\n" ;
- is join('', @lines), $str ;
- is $., 6;
- is $io->tell(), length($str) ;
-
- ok $io->eof;
-
- ok ! ( defined($io->getline) ||
- (@tmp = $io->getlines) ||
- defined($io->getline) ||
- defined($io->getc) ||
- $io->read($buf, 100) != 0) ;
- }
-
-
- {
- local $/; # slurp mode
- my $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my @lines = $io->getlines;
- ok $io->eof;
- ok @lines == 1 && $lines[0] eq $str;
-
- $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my $line = $io->getline();
- ok $line eq $str;
- ok $io->eof;
- }
-
- {
- local $/ = ""; # paragraph mode
- my $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my @lines = $io->getlines();
- ok $io->eof;
- ok @lines == 2
- or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
- ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
- or print "# $lines[0]\n";
- ok $lines[1] eq "and a single line.\n\n";
- }
-
- {
- local $/ = "is";
- my $io = $UncompressClass->new($name);
- my @lines = ();
- my $no = 0;
- my $err = 0;
- ok ! $io->eof;
- while (my $a = $io->getline()) {
- push(@lines, $a);
- $err++ if $. != ++$no;
- }
-
- ok $err == 0 ;
- ok $io->eof;
-
- ok @lines == 3
- or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
- ok join("-", @lines) eq
- "This- is- an example\n" .
- "of a paragraph\n\n\n" .
- "and a single line.\n\n";
- }
-
-
- # Test read
-
- {
- my $io = $UncompressClass->new($name);
-
-
- eval { $io->read(1) } ;
- like $@, mkErr("buffer parameter is read-only");
-
- is $io->read($buf, 0), 0, "Requested 0 bytes" ;
-
- ok $io->read($buf, 3) == 3 ;
- ok $buf eq "Thi";
-
- ok $io->sysread($buf, 3, 2) == 3 ;
- ok $buf eq "Ths i"
- or print "# [$buf]\n" ;;
- ok ! $io->eof;
-
- # $io->seek(-4, 2);
- #
- # ok ! $io->eof;
- #
- # ok read($io, $buf, 20) == 4 ;
- # ok $buf eq "e.\n\n";
- #
- # ok read($io, $buf, 20) == 0 ;
- # ok $buf eq "";
- #
- # ok ! $io->eof;
- }
-
- }
-
- {
- # Read from non-compressed file
-
- my $str = <<EOT;
-This is an example
-of a paragraph
-
-
-and a single line.
-
-EOT
-
- my $lex = new LexFile my $name ;
-
- writeFile($name, $str);
- my @tmp;
- my $buf;
- {
- my $io = new $UncompressClass $name, -Transparent => 1 ;
-
- ok defined $io;
- ok ! $io->eof;
- ok $io->tell() == 0 ;
- my @lines = $io->getlines();
- ok @lines == 6;
- ok $lines[1] eq "of a paragraph\n" ;
- ok join('', @lines) eq $str ;
- ok $. == 6;
- ok $io->tell() == length($str) ;
-
- ok $io->eof;
-
- ok ! ( defined($io->getline) ||
- (@tmp = $io->getlines) ||
- defined($io->getline) ||
- defined($io->getc) ||
- $io->read($buf, 100) != 0) ;
- }
-
-
- {
- local $/; # slurp mode
- my $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my @lines = $io->getlines;
- ok $io->eof;
- ok @lines == 1 && $lines[0] eq $str;
-
- $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my $line = $io->getline;
- ok $line eq $str;
- ok $io->eof;
- }
-
- {
- local $/ = ""; # paragraph mode
- my $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my @lines = $io->getlines;
- ok $io->eof;
- ok @lines == 2
- or print "# exected 2 lines, got " . scalar(@lines) . "\n";
- ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
- or print "# [$lines[0]]\n" ;
- ok $lines[1] eq "and a single line.\n\n";
- }
-
- {
- local $/ = "is";
- my $io = $UncompressClass->new($name);
- my @lines = ();
- my $no = 0;
- my $err = 0;
- ok ! $io->eof;
- while (my $a = $io->getline) {
- push(@lines, $a);
- $err++ if $. != ++$no;
- }
-
- ok $err == 0 ;
- ok $io->eof;
-
- ok @lines == 3 ;
- ok join("-", @lines) eq
- "This- is- an example\n" .
- "of a paragraph\n\n\n" .
- "and a single line.\n\n";
- }
-
-
- # Test read
-
- {
- my $io = $UncompressClass->new($name);
-
- ok $io->read($buf, 3) == 3 ;
- ok $buf eq "Thi";
-
- ok $io->sysread($buf, 3, 2) == 3 ;
- ok $buf eq "Ths i";
- ok ! $io->eof;
-
- # $io->seek(-4, 2);
- #
- # ok ! $io->eof;
- #
- # ok read($io, $buf, 20) == 4 ;
- # ok $buf eq "e.\n\n";
- #
- # ok read($io, $buf, 20) == 0 ;
- # ok $buf eq "";
- #
- # ok ! $io->eof;
- }
-
-
- }
-
- {
- # Vary the length parameter in a read
-
- my $str = <<EOT;
-x
-x
-This is an example
-of a paragraph
-
-
-and a single line.
-
-EOT
- $str = $str x 100 ;
-
-
- foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
- {
- foreach my $trans (0, 1)
- {
- foreach my $append (0, 1)
- {
- title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
-
- my $lex = new LexFile my $name ;
-
- if ($trans) {
- writeFile($name, $str) ;
- }
- else {
- my $iow = new $CompressClass $name;
- $iow->print($str) ;
- $iow->close ;
- }
-
-
- my $io = $UncompressClass->new($name,
- -Append => $append,
- -Transparent => $trans);
-
- my $buf;
-
- is $io->tell(), 0;
-
- if ($append) {
- 1 while $io->read($buf, $bufsize) > 0;
- }
- else {
- my $tmp ;
- $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
- }
- is length $buf, length $str;
- ok $buf eq $str ;
- ok ! $io->error() ;
- ok $io->eof;
- }
- }
- }
- }
-
- foreach my $file (0, 1)
- {
- foreach my $trans (0, 1)
- {
- title "seek tests - file $file trans $trans" ;
-
- my $buffer ;
- my $buff ;
- my $lex = new LexFile my $name ;
-
- my $first = "beginning" ;
- my $last = "the end" ;
-
- if ($trans)
- {
- $buffer = $first . "\x00" x 10 . $last;
- writeFile($name, $buffer);
- }
- else
- {
- my $output ;
- if ($file)
- {
- $output = $name ;
- }
- else
- {
- $output = \$buffer;
- }
-
- my $iow = new $CompressClass $output ;
- $iow->print($first) ;
- ok $iow->seek(5, SEEK_CUR) ;
- ok $iow->tell() == length($first)+5;
- ok $iow->seek(0, SEEK_CUR) ;
- ok $iow->tell() == length($first)+5;
- ok $iow->seek(length($first)+10, SEEK_SET) ;
- ok $iow->tell() == length($first)+10;
-
- $iow->print($last) ;
- $iow->close ;
- }
-
- my $input ;
- if ($file)
- {
- $input = $name ;
- }
- else
- {
- $input = \$buffer ;
- }
-
- ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ;
-
- my $io = $UncompressClass->new($input, Strict => 1);
- ok $io->seek(length($first), SEEK_CUR) ;
- ok ! $io->eof;
- is $io->tell(), length($first);
-
- ok $io->read($buff, 5) ;
- is $buff, "\x00" x 5 ;
- is $io->tell(), length($first) + 5;
-
- ok $io->seek(0, SEEK_CUR) ;
- my $here = $io->tell() ;
- is $here, length($first)+5;
-
- ok $io->seek($here+5, SEEK_SET) ;
- is $io->tell(), $here+5 ;
- ok $io->read($buff, 100) ;
- ok $buff eq $last ;
- ok $io->eof;
- }
- }
-
- {
- title "seek error cases" ;
-
- my $b ;
- my $a = new $CompressClass(\$b) ;
-
- ok ! $a->error() ;
- eval { $a->seek(-1, 10) ; };
- like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter");
-
- eval { $a->seek(-1, SEEK_END) ; };
- like $@, mkErr("^${CompressClass}::seek: cannot seek backwards");
-
- $a->write("fred");
- $a->close ;
-
-
- my $u = new $UncompressClass(\$b) ;
-
- eval { $u->seek(-1, 10) ; };
- like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter");
-
- eval { $u->seek(-1, SEEK_END) ; };
- like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed");
-
- eval { $u->seek(-1, SEEK_CUR) ; };
- like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards");
- }
-
- foreach my $fb (qw(filename buffer filehandle))
- {
- foreach my $append (0, 1)
- {
- {
- title "$CompressClass -- Append $append, Output to $fb" ;
-
- my $lex = new LexFile my $name ;
-
- my $already = 'already';
- my $buffer = $already;
- my $output;
-
- if ($fb eq 'buffer')
- { $output = \$buffer }
- elsif ($fb eq 'filename')
- {
- $output = $name ;
- writeFile($name, $buffer);
- }
- elsif ($fb eq 'filehandle')
- {
- $output = new IO::File ">$name" ;
- print $output $buffer;
- }
-
- my $a = new $CompressClass($output, Append => $append) ;
- ok $a, " Created $CompressClass";
- my $string = "appended";
- $a->write($string);
- $a->close ;
-
- my $data ;
- if ($fb eq 'buffer')
- {
- $data = $buffer;
- }
- else
- {
- $output->close
- if $fb eq 'filehandle';
- $data = readFile($name);
- }
-
- if ($append || $fb eq 'filehandle')
- {
- is substr($data, 0, length($already)), $already, " got prefix";
- substr($data, 0, length($already)) = '';
- }
-
-
- my $uncomp;
- my $x = new $UncompressClass(\$data, Append => 1) ;
- ok $x, " created $UncompressClass";
-
- my $len ;
- 1 while ($len = $x->read($uncomp)) > 0 ;
-
- $x->close ;
- is $uncomp, $string, ' Got uncompressed data' ;
-
- }
- }
- }
-
- foreach my $type (qw(buffer filename filehandle))
- {
- title "$UncompressClass -- InputLength, read from $type";
-
- my $compressed ;
- my $string = "some data";
- my $c = new $CompressClass(\$compressed);
- $c->write($string);
- $c->close();
-
- my $appended = "append";
- my $comp_len = length $compressed;
- $compressed .= $appended;
-
- my $lex = new LexFile my $name ;
- my $input ;
- writeFile ($name, $compressed);
-
- if ($type eq 'buffer')
- {
- $input = \$compressed;
- }
- if ($type eq 'filename')
- {
- $input = $name;
- }
- elsif ($type eq 'filehandle')
- {
- my $fh = new IO::File "<$name" ;
- ok $fh, "opened file $name ok";
- $input = $fh ;
- }
-
- my $x = new $UncompressClass($input, InputLength => $comp_len) ;
- ok $x, " created $UncompressClass";
-
- my $len ;
- my $output;
- $len = $x->read($output, 100);
- is $len, length($string);
- is $output, $string;
-
- if ($type eq 'filehandle')
- {
- my $rest ;
- $input->read($rest, 1000);
- is $rest, $appended;
- }
-
-
- }
-
- foreach my $append (0, 1)
- {
- title "$UncompressClass -- Append $append" ;
-
- my $lex = new LexFile my $name ;
-
- my $string = "appended";
- my $compressed ;
- my $c = new $CompressClass(\$compressed);
- $c->write($string);
- $c->close();
-
- my $x = new $UncompressClass(\$compressed, Append => $append) ;
- ok $x, " created $UncompressClass";
-
- my $already = 'already';
- my $output = $already;
-
- my $len ;
- $len = $x->read($output, 100);
- is $len, length($string);
-
- $x->close ;
-
- if ($append)
- {
- is substr($output, 0, length($already)), $already, " got prefix";
- substr($output, 0, length($already)) = '';
- }
- is $output, $string, ' Got uncompressed data' ;
- }
-
-
- foreach my $file (0, 1)
- {
- foreach my $trans (0, 1)
- {
- title "ungetc, File $file, Transparent $trans" ;
-
- my $lex = new LexFile my $name ;
-
- my $string = 'abcdeABCDE';
- my $b ;
- if ($trans)
- {
- $b = $string ;
- }
- else
- {
- my $a = new $CompressClass(\$b) ;
- $a->write($string);
- $a->close ;
- }
-
- my $from ;
- if ($file)
- {
- writeFile($name, $b);
- $from = $name ;
- }
- else
- {
- $from = \$b ;
- }
-
- my $u = $UncompressClass->new($from, Transparent => 1) ;
- my $first;
- my $buff ;
-
- # do an ungetc before reading
- $u->ungetc("X");
- $first = $u->getc();
- is $first, 'X';
-
- $first = $u->getc();
- is $first, substr($string, 0,1);
- $u->ungetc($first);
- $first = $u->getc();
- is $first, substr($string, 0,1);
- $u->ungetc($first);
-
- is $u->read($buff, 5), 5 ;
- is $buff, substr($string, 0, 5);
-
- $u->ungetc($buff) ;
- is $u->read($buff, length($string)), length($string) ;
- is $buff, $string;
-
- ok $u->eof() ;
-
- my $extra = 'extra';
- $u->ungetc($extra);
- ok ! $u->eof();
- is $u->read($buff), length($extra) ;
- is $buff, $extra;
-
- ok $u->eof() ;
-
- $u->close();
-
- }
- }
-
- {
- title "inflateSync on plain file";
-
- my $hello = "I am a HAL 9000 computer" x 2001 ;
-
- my $k = new $UncompressClass(\$hello, Transparent => 1);
- ok $k ;
-
- # Skip to the flush point -- no-op for plain file
- my $status = $k->inflateSync();
- is $status, 1
- or diag $k->error() ;
-
- my $rest;
- is $k->read($rest, length($hello)), length($hello)
- or diag $k->error() ;
- ok $rest eq $hello ;
-
- ok $k->close();
- }
-
- {
- title "inflateSync for real";
-
- # create a deflate stream with flush points
-
- my $hello = "I am a HAL 9000 computer" x 2001 ;
- my $goodbye = "Will I dream?" x 2010;
- my ($x, $err, $answer, $X, $Z, $status);
- my $Answer ;
-
- ok ($x = new $CompressClass(\$Answer));
- ok $x ;
-
- is $x->write($hello), length($hello);
-
- # create a flush point
- ok $x->flush(Z_FULL_FLUSH) ;
-
- is $x->write($goodbye), length($goodbye);
-
- ok $x->close() ;
-
- my $k;
- $k = new $UncompressClass(\$Answer, BlockSize => 1);
- ok $k ;
-
- my $initial;
- is $k->read($initial, 1), 1 ;
- is $initial, substr($hello, 0, 1);
-
- # Skip to the flush point
- $status = $k->inflateSync();
- is $status, 1
- or diag $k->error() ;
-
- my $rest;
- is $k->read($rest, length($hello) + length($goodbye)),
- length($goodbye)
- or diag $k->error() ;
- ok $rest eq $goodbye ;
-
- ok $k->close();
- }
-
- {
- title "inflateSync no FLUSH point";
-
- # create a deflate stream with flush points
-
- my $hello = "I am a HAL 9000 computer" x 2001 ;
- my ($x, $err, $answer, $X, $Z, $status);
- my $Answer ;
-
- ok ($x = new $CompressClass(\$Answer));
- ok $x ;
-
- is $x->write($hello), length($hello);
-
- ok $x->close() ;
-
- my $k = new $UncompressClass(\$Answer, BlockSize => 1);
- ok $k ;
-
- my $initial;
- is $k->read($initial, 1), 1 ;
- is $initial, substr($hello, 0, 1);
-
- # Skip to the flush point
- $status = $k->inflateSync();
- is $status, 0
- or diag $k->error() ;
-
- ok $k->close();
- is $k->inflateSync(), 0 ;
- }
-
- {
- title "write tests - invalid data" ;
-
- #my $lex = new LexFile my $name1 ;
- my $Answer ;
-
- #ok ! -e $name1, " File $name1 does not exist";
-
- my @data = (
- [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
- [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
- [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
- [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ],
- [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ],
- [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ],
- #[ "not readable", 'xx' ],
- # same filehandle twice, 'xx'
- ) ;
-
- foreach my $data (@data)
- {
- my ($send, $get) = @$data ;
- title "${CompressClass}::write( $send )";
- my $copy;
- eval "\$copy = $send";
- my $x = new $CompressClass(\$Answer);
- ok $x, " Created $CompressClass object";
- eval { $x->write($copy) } ;
- #like $@, "/^$get/", " error - $get";
- like $@, "/not a scalar reference /", " error - not a scalar reference";
- }
-
-# @data = (
-# [ '[ $name1 ]', "input file '$name1' does not exist" ],
-# #[ "not readable", 'xx' ],
-# # same filehandle twice, 'xx'
-# ) ;
-#
-# foreach my $data (@data)
-# {
-# my ($send, $get) = @$data ;
-# title "${CompressClass}::write( $send )";
-# my $copy;
-# eval "\$copy = $send";
-# my $x = new $CompressClass(\$Answer);
-# ok $x, " Created $CompressClass object";
-# ok ! $x->write($copy), " write fails" ;
-# like $$Error, "/^$get/", " error - $get";
-# }
-
- #exit;
-
- }
-
-
-# sub deepCopy
-# {
-# if (! ref $_[0] || ref $_[0] eq 'SCALAR')
-# {
-# return $_[0] ;
-# }
-#
-# if (ref $_[0] eq 'ARRAY')
-# {
-# my @a ;
-# for my $x ( @{ $_[0] })
-# {
-# push @a, deepCopy($x);
-# }
-#
-# return \@a ;
-# }
-#
-# croak "bad! $_[0]";
-#
-# }
-#
-# sub deepSubst
-# {
-# #my $data = shift ;
-# my $from = $_[1] ;
-# my $to = $_[2] ;
-#
-# if (! ref $_[0])
-# {
-# $_[0] = $to
-# if $_[0] eq $from ;
-# return ;
-#
-# }
-#
-# if (ref $_[0] eq 'SCALAR')
-# {
-# $_[0] = \$to
-# if defined ${ $_[0] } && ${ $_[0] } eq $from ;
-# return ;
-#
-# }
-#
-# if (ref $_[0] eq 'ARRAY')
-# {
-# for my $x ( @{ $_[0] })
-# {
-# deepSubst($x, $from, $to);
-# }
-# return ;
-# }
-# #croak "bad! $_[0]";
-# }
-
-# {
-# title "More write tests" ;
-#
-# my $file1 = "file1" ;
-# my $file2 = "file2" ;
-# my $file3 = "file3" ;
-# my $lex = new LexFile $file1, $file2, $file3 ;
-#
-# writeFile($file1, "F1");
-# writeFile($file2, "F2");
-# writeFile($file3, "F3");
-#
-# my @data = (
-# [ '""', "" ],
-# [ 'undef', "" ],
-# [ '"abcd"', "abcd" ],
-#
-# [ '\""', "" ],
-# [ '\undef', "" ],
-# [ '\"abcd"', "abcd" ],
-#
-# [ '[]', "" ],
-# [ '[[]]', "" ],
-# [ '[[[]]]', "" ],
-# [ '[\""]', "" ],
-# [ '[\undef]', "" ],
-# [ '[\"abcd"]', "abcd" ],
-# [ '[\"ab", \"cd"]', "abcd" ],
-# [ '[[\"ab"], [\"cd"]]', "abcd" ],
-#
-# [ '$file1', $file1 ],
-# [ '$fh2', "F2" ],
-# [ '[$file1, \"abc"]', "F1abc"],
-# [ '[\"a", $file1, \"bc"]', "aF1bc"],
-# [ '[\"a", $fh1, \"bc"]', "aF1bc"],
-# [ '[\"a", $fh1, \"bc", $file2]', "aF1bcF2"],
-# [ '[\"a", $fh1, \"bc", $file2, $fh3]', "aF1bcF2F3"],
-# ) ;
-#
-#
-# foreach my $data (@data)
-# {
-# my ($send, $get) = @$data ;
-#
-# my $fh1 = new IO::File "< $file1" ;
-# my $fh2 = new IO::File "< $file2" ;
-# my $fh3 = new IO::File "< $file3" ;
-#
-# title "${CompressClass}::write( $send )";
-# my $copy;
-# eval "\$copy = $send";
-# my $Answer ;
-# my $x = new $CompressClass(\$Answer);
-# ok $x, " Created $CompressClass object";
-# my $len = length $get;
-# is $x->write($copy), length($get), " write $len bytes";
-# ok $x->close(), " close ok" ;
-#
-# is myGZreadFile(\$Answer), $get, " got expected output" ;
-# cmp_ok $$Error, '==', 0, " no error";
-#
-#
-# }
-#
-# }
-}
-
-
-
-
-
-
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "generic.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub identify
+{
+ return 'IO::Compress::Gzip';
+}
+
+require "generic.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "generic.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "generic.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "zlib-generic.pl" ;
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "zlib-generic.pl" ;
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "zlib-generic.pl" ;
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "zlib-generic.pl" ;
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
check "$Perl ${examples}/gzgrep the $file1 $file2",
join('', grep(/the/, @hello1, @hello2));
-for ($file1, $file2) { 1 while unlink $_ } ;
+for ($file1, $file2, $stderr) { 1 while unlink $_ } ;
+
# filtdef/filtinf
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
my ($input, $err, $answer, $X, $status, $Answer);
- my $lex = new LexFile my $name;
+ my $lex = new LexFile my $name ;
ok my $x = gzopen($name, "wb");
$input .= $hello;
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
ok ! $fil->gzclose, "gzclose ok" ;
is $s, Encode::decode_utf8($uncomp), " decode_utf8 ok" ;
-
}
# Add tests that check that the module traps use of wide chars
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
- plan tests => 920 + $extra ;
+ plan tests => 942 + $extra ;
use_ok('Compress::Zlib', 2) ;
use_ok('Compress::Gzip::Constants') ;
for my $code ( -1, undef, '', 'fred' )
{
- my $code_name = defined $code ? "'$code'" : 'undef';
+ my $code_name = defined $code ? "'$code'" : "'undef'";
eval { new IO::Compress::Gzip $name, -OS_Code => $code } ;
like $@, mkErr("^IO::Compress::Gzip: Parameter 'OS_Code' must be an unsigned int, got $code_name"),
" Trap OS Code $code_name";
for my $code ( qw( 256 ) )
{
- ok ! new IO::Compress::Gzip($name, OS_Code => $code) ;
- like $GzipError, "/^OS_Code must be between 0 and 255, got '$code'/",
+ eval { ok ! new IO::Compress::Gzip($name, OS_Code => $code) };
+ like $@, mkErr("OS_Code must be between 0 and 255, got '$code'"),
+ " Trap OS Code $code";
+ like $GzipError, "/OS_Code must be between 0 and 255, got '$code'/",
" Trap OS Code $code";
}
my $extra = $hdr->{ExtraField} ;
if ($order) {
- eq_array $extra, $result
+ eq_array $extra, $result;
} else {
eq_set $extra, $result;
}
foreach my $test (@tests) {
my ($input, $string) = @$test ;
my $buffer ;
- my $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input;
+ my $x ;
+ eval { $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input; };
+ like $@, mkErr("$prefix$string");
+ like $GzipError, "/$prefix$string/";
ok ! $x ;
- like $GzipError, "/^$prefix$string/";
}
#hexDump(\$input);
my $buffer ;
- my $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input, Strict => 1;
+ my $x ;
+ eval {$x = new IO::Compress::Gzip \$buffer, -ExtraField => $input, Strict => 1; };
+ like $@, mkErr("$gzip_error"), " $name";
+ like $GzipError, "/$gzip_error/", " $name";
ok ! $x, " IO::Compress::Gzip fails";
- like $GzipError, "/^$gzip_error/", " $name";
+ like $GzipError, "/$gzip_error/", " $name";
foreach my $check (0, 1)
{
is anyUncompress(\$buffer), $string ;
$x = new IO::Uncompress::Gunzip \$buffer, Strict => 0,
+ Transparent => 0,
ParseExtra => $check;
if ($check) {
ok ! $x ;
{
title "Header Corruption - ExtraField too big";
my $x;
- ok ! new IO::Compress::Gzip(\$x,
- -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ;
+ eval { new IO::Compress::Gzip(\$x, -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ;};
+ like $@, mkErr('Error with ExtraField Parameter: Too Large');
like $GzipError, '/Error with ExtraField Parameter: Too Large/';
}
title "Header Corruption - Create Name with Illegal Chars";
my $x;
- ok ! new IO::Compress::Gzip \$x,
- -Name => "fred\x02" ;
+ eval { new IO::Compress::Gzip \$x, -Name => "fred\x02" };
+ like $@, mkErr('Non ISO 8859-1 Character found in Name');
like $GzipError, '/Non ISO 8859-1 Character found in Name/';
ok my $gz = new IO::Compress::Gzip \$x,
ok $gz->close();
ok ! new IO::Uncompress::Gunzip \$x,
+ -Transparent => 0,
-Strict => 1;
like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Name/';
{
title "Header Corruption - Null Chars in Name";
my $x;
- ok ! new IO::Compress::Gzip \$x,
- -Name => "\x00" ;
+ eval { new IO::Compress::Gzip \$x, -Name => "\x00" };
+ like $@, mkErr('Null Character found in Name');
like $GzipError, '/Null Character found in Name/';
- ok ! new IO::Compress::Gzip \$x,
- -Name => "abc\x00" ;
+ eval { new IO::Compress::Gzip \$x, -Name => "abc\x00" };
+ like $@, mkErr('Null Character found in Name');
like $GzipError, '/Null Character found in Name/';
ok my $gz = new IO::Compress::Gzip \$x,
title "Header Corruption - Create Comment with Illegal Chars";
my $x;
- ok ! new IO::Compress::Gzip \$x,
- -Comment => "fred\x02" ;
+ eval { new IO::Compress::Gzip \$x, -Comment => "fred\x02" };
+ like $@, mkErr('Non ISO 8859-1 Character found in Comment');
like $GzipError, '/Non ISO 8859-1 Character found in Comment/';
ok my $gz = new IO::Compress::Gzip \$x,
-Comment => "fred\x02" ;
ok $gz->close();
- ok ! new IO::Uncompress::Gunzip \$x, Strict => 1;
+ ok ! new IO::Uncompress::Gunzip \$x, Strict => 1,
+ -Transparent => 0;
like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Comment/';
ok my $gunzip = new IO::Uncompress::Gunzip \$x, Strict => 0;
{
title "Header Corruption - Null Char in Comment";
my $x;
- ok ! new IO::Compress::Gzip \$x,
- -Comment => "\x00" ;
+ eval { new IO::Compress::Gzip \$x, -Comment => "\x00" };
+ like $@, mkErr('Null Character found in Comment');
like $GzipError, '/Null Character found in Comment/';
- ok ! new IO::Compress::Gzip \$x,
- -Comment => "abc\x00" ;
+ eval { new IO::Compress::Gzip \$x, -Comment => "abc\x00" } ;
+ like $@, mkErr('Null Character found in Comment');
like $GzipError, '/Null Character found in Comment/';
ok my $gz = new IO::Compress::Gzip \$x,
ok $gunz->read($uncomp) > 0 ;
ok ! $GunzipError ;
my $expected = substr($buffer, - $got);
- is ${ $gunz->trailingData() }, $expected_trailing;
+ is $gunz->trailingData(), $expected_trailing;
}
ok $gunz->eof() ;
ok $uncomp eq $string;
ok ! $GunzipError ;
#is $gunz->trailingData(), substr($buffer, - $got) ;
}
- ok ! ${ $gunz->trailingData() } ;
+ ok ! $gunz->trailingData() ;
ok $gunz->eof() ;
ok $uncomp eq $string;
ok $gunz->close ;
ok $gunz->read($uncomp) > 0 ;
ok ! $GunzipError ;
}
- ok ! ${ $gunz->trailingData() } ;
+ ok ! $gunz->trailingData() ;
ok $gunz->eof() ;
ok $uncomp eq $string;
ok $gunz->close ;
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/',
"Trailer Error: CRC mismatch";
ok $gunz->eof() ;
- ok ! ${ $gunz->trailingData() } ;
+ ok ! $gunz->trailingData() ;
ok $uncomp eq $string;
ok $gunz->close ;
}
my $uncomp ;
ok $gunz->read($uncomp) >= 0 ;
ok $gunz->eof() ;
- ok ! ${ $gunz->trailingData() } ;
+ ok ! $gunz->trailingData() ;
ok $uncomp eq $string;
ok $gunz->close ;
}
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
use warnings;
use bytes;
+# TODO -- split out & add zip/bzip2
+
use Test::More ;
use ZlibTestUtils;
ok $gz;
ok ! $gz->error() ;
my $buff = '';
- ok $gz->read($buff) == length $part ;
- ok $buff eq $part ;
+ is $gz->read($buff), length $part ;
+ is $buff, $part ;
ok $gz->eof() ;
$gz->close();
}
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+
+use IO::Uncompress::AnyInflate qw($AnyInflateError) ;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub getClass
+{
+ 'AnyInflate';
+}
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "any.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Uncompress::AnyInflate qw($AnyInflateError) ;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub getClass
+{
+ 'AnyInflate';
+}
+
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "any.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Uncompress::AnyInflate qw($AnyInflateError) ;
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub getClass
+{
+ 'AnyInflate';
+}
+
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "any.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+BEGIN {
+ # use Test::NoWarnings, if available
+ my $extra = 0 ;
+ $extra = 1
+ if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
+
+ plan tests => 15 + $extra ;
+
+ use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ;
+
+}
+
+{
+
+ my $string = <<EOM;
+This is not compressed data
+EOM
+
+ my $buffer = $string ;
+
+ for my $file (0, 1)
+ {
+ title "AnyInflate with Non-compressed data (File $file)" ;
+
+ my $lex = new LexFile my $output;
+ my $input ;
+
+ if ($file) {
+ writeFile($output, $buffer);
+ $input = $output;
+ }
+ else {
+ $input = \$buffer;
+ }
+
+
+ my $unc ;
+ my $keep = $buffer ;
+ $unc = new IO::Uncompress::AnyInflate $input, -Transparent => 0 ;
+ ok ! $unc," no AnyInflate object when -Transparent => 0" ;
+ is $buffer, $keep ;
+
+ $buffer = $keep ;
+ $unc = new IO::Uncompress::AnyInflate \$buffer, -Transparent => 1 ;
+ ok $unc, " AnyInflate object when -Transparent => 1" ;
+
+ my $uncomp ;
+ ok $unc->read($uncomp) > 0 ;
+ ok $unc->eof() ;
+ #ok $unc->type eq $Type;
+
+ is $uncomp, $string ;
+ }
+}
+
+1;
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Uncompress::AnyInflate qw($AnyInflateError) ;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub getClass
+{
+ 'AnyInflate';
+}
+
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "any.pl" ;
+run();
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = ("../lib", "lib");
- }
-}
-
-use lib 't';
-
-use strict;
-use warnings;
-use bytes;
-
-use Test::More ;
-use ZlibTestUtils;
-
-BEGIN {
- # use Test::NoWarnings, if available
- my $extra = 0 ;
- $extra = 1
- if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
-
- plan tests => 63 + $extra ;
-
- use_ok('Compress::Zlib', 2) ;
-
- use_ok('IO::Compress::Gzip', qw($GzipError)) ;
- use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
-
- use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
- use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
-
- use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
- use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
- use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ;
-}
-
-foreach my $Class ( map { "IO::Compress::$_" } qw( Gzip Deflate RawDeflate) )
-{
-
- for my $trans ( 0, 1 )
- {
- title "AnyInflate(Transparent => $trans) with $Class" ;
- my $string = <<EOM;
-some text
-EOM
-
- my $buffer ;
- my $x = new $Class(\$buffer) ;
- ok $x, " create $Class object" ;
- ok $x->write($string), " write to object" ;
- ok $x->close, " close ok" ;
-
- my $unc = new IO::Uncompress::AnyInflate \$buffer, Transparent => $trans ;
-
- ok $unc, " Created AnyInflate object" ;
- my $uncomp ;
- ok $unc->read($uncomp) > 0
- or print "# $IO::Uncompress::AnyInflate::AnyInflateError\n";
- ok $unc->eof(), " at eof" ;
- #ok $unc->type eq $Type;
-
- is $uncomp, $string, " expected output" ;
- }
-
-}
-
-{
- title "AnyInflate with Non-compressed data" ;
-
- my $string = <<EOM;
-This is not compressed data
-EOM
-
- my $buffer = $string ;
-
- my $unc ;
- my $keep = $buffer ;
- $unc = new IO::Uncompress::AnyInflate \$buffer, -Transparent => 0 ;
- ok ! $unc," no AnyInflate object when -Transparent => 0" ;
- is $buffer, $keep ;
-
- $buffer = $keep ;
- $unc = new IO::Uncompress::AnyInflate \$buffer, -Transparent => 1 ;
- ok $unc, " AnyInflate object when -Transparent => 1" ;
-
- my $uncomp ;
- ok $unc->read($uncomp) > 0 ;
- ok $unc->eof() ;
- #ok $unc->type eq $Type;
-
- is $uncomp, $string ;
-}
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "prime.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "prime.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "prime.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "prime.pl" ;
+run();
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = ("../lib", "lib");
- }
-}
-
-use lib 't';
-use strict;
-use warnings;
-use bytes;
-
-use Test::More ;
-use ZlibTestUtils;
-
-BEGIN {
- # use Test::NoWarnings, if available
- my $extra = 0 ;
- $extra = 1
- if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
-
- plan tests => 10612 + $extra ;
-
-
- use_ok('Compress::Zlib', 2) ;
-
- use_ok('IO::Compress::Gzip', qw($GzipError)) ;
- use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
-
- use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
- use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
-
- use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
- use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
-}
-
-
-my $hello = <<EOM ;
-hello world
-this is a test
-some more stuff on this line
-ad finally...
-EOM
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- my $UncompressClass = getInverse($CompressClass);
-
-
- print "#\n# Testing $UncompressClass\n#\n";
-
- my $compressed ;
- my $cc ;
- my $gz ;
- my $hsize ;
- if ($CompressClass eq 'IO::Compress::Gzip') {
- ok( my $x = new IO::Compress::Gzip \$compressed,
- -Name => "My name",
- -Comment => "this is a comment",
- -ExtraField => [ 'ab' => "extra"],
- -HeaderCRC => 1);
- ok $x->write($hello) ;
- ok $x->close ;
- $cc = $compressed ;
-
- #hexDump($compressed) ;
-
- ok($gz = new IO::Uncompress::Gunzip \$cc,
- #-Strict => 1,
- -Transparent => 0)
- or print "$GunzipError\n";
- my $un;
- ok $gz->read($un) > 0 ;
- ok $gz->close();
- ok $un eq $hello ;
- }
- else {
- ok( my $x = new $CompressClass(\$compressed));
- ok $x->write($hello) ;
- ok $x->close ;
- $cc = $compressed ;
-
- ok($gz = new $UncompressClass(\$cc,
- -Transparent => 0))
- or print "$GunzipError\n";
- my $un;
- ok $gz->read($un) > 0 ;
- ok $gz->close();
- ok $un eq $hello ;
- }
-
- for my $blocksize (1,2,13)
- {
- for my $i (0 .. length($compressed) - 1)
- {
- for my $useBuf (0 .. 1)
- {
- print "#\n# BlockSize $blocksize, Length $i, Buffer $useBuf\n#\n" ;
- my $lex = new LexFile my $name ;
-
- my $prime = substr($compressed, 0, $i);
- my $rest = substr($compressed, $i);
-
- my $start ;
- if ($useBuf) {
- $start = \$rest ;
- }
- else {
- $start = $name ;
- writeFile($name, $rest);
- }
-
- #my $gz = new $UncompressClass $name,
- my $gz = new $UncompressClass $start,
- -Append => 1,
- -BlockSize => $blocksize,
- -Prime => $prime,
- -Transparent => 0
- ;
- ok $gz;
- ok ! $gz->error() ;
- my $un ;
- my $status = 1 ;
- $status = $gz->read($un) while $status > 0 ;
- ok $status == 0
- or print "status $status\n" ;
- ok ! $gz->error()
- or print "Error is '" . $gz->error() . "'\n";
- ok $un eq $hello
- or print "# got [$un]\n";
- ok $gz->eof() ;
- ok $gz->close() ;
- }
- }
- }
-}
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
ok ! $fil->gzclose ;
ok $fil->gzeof() ;
-
is $uncomp, $hello, "got expected output" ;
-
-
}
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "multi.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "multi.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "multi.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "multi.pl" ;
+run();
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = ("../lib", "lib");
- }
-}
-
-use lib 't';
-use strict;
-use warnings;
-use bytes;
-
-use Test::More ;
-use ZlibTestUtils;
-
-BEGIN {
- # use Test::NoWarnings, if available
- my $extra = 0 ;
- $extra = 1
- if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
-
- plan tests => 575 + $extra ;
-
- use_ok('Compress::Zlib', 2) ;
-
- use_ok('IO::Compress::Gzip', qw($GzipError)) ;
- use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
- use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ;
- use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
- use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
- use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
- use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
-}
-
-
-my @buffers ;
-push @buffers, <<EOM ;
-hello world
-this is a test
-some more stuff on this line
-ad finally...
-EOM
-
-push @buffers, <<EOM ;
-some more stuff
-EOM
-
-push @buffers, <<EOM ;
-even more stuff
-EOM
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- my $UncompressClass = getInverse($CompressClass);
-
-
- my $cc ;
- my $gz ;
- my $hsize ;
- my %headers = () ;
-
-
- foreach my $fb ( qw( file filehandle buffer ) )
- {
-
- foreach my $i (1 .. @buffers) {
-
- title "Testing $CompressClass with $i streams to $fb";
-
- my @buffs = @buffers[0..$i -1] ;
-
- if ($CompressClass eq 'IO::Compress::Gzip') {
- %headers = (
- Strict => 0,
- Comment => "this is a comment",
- ExtraField => "some extra",
- HeaderCRC => 1);
-
- }
-
- my $lex = new LexFile my $name ;
- my $output ;
- if ($fb eq 'buffer')
- {
- my $compressed = '';
- $output = \$compressed;
- }
- elsif ($fb eq 'filehandle')
- {
- $output = new IO::File ">$name" ;
- }
- else
- {
- $output = $name ;
- }
-
- my $x = new $CompressClass($output, AutoClose => 1, %headers);
- isa_ok $x, $CompressClass, ' $x' ;
-
- foreach my $buffer (@buffs) {
- ok $x->write($buffer), " Write OK" ;
- # this will add an extra "empty" stream
- ok $x->newStream(), " newStream OK" ;
- }
- ok $x->close, " Close ok" ;
-
- #hexDump($compressed) ;
-
- foreach my $unc ($UncompressClass, 'IO::Uncompress::AnyInflate') {
- title " Testing $CompressClass with $unc and $i streams, from $fb";
- $cc = $output ;
- if ($fb eq 'filehandle')
- {
- $cc = new IO::File "<$name" ;
- }
- my $gz = new $unc($cc,
- Strict => 0,
- AutoClose => 1,
- Append => 1,
- MultiStream => 1,
- Transparent => 0);
- isa_ok $gz, $unc, ' $gz' ;
-
- my $un = '';
- 1 while $gz->read($un) > 0 ;
- #print "[[$un]]\n" while $gz->read($un) > 0 ;
- ok ! $gz->error(), " ! error()"
- or diag "Error is " . $gz->error() ;
- ok $gz->eof(), " eof()";
- ok $gz->close(), " close() ok"
- or diag "errno $!\n" ;
-
- is $gz->streamCount(), $i +1, " streamCount ok"
- or diag "Stream count is " . $gz->streamCount();
- ok $un eq join('', @buffs), " expected output" ;
-
- }
- }
- }
-}
-
-
-# corrupt one of the streams - all previous should be ok
-# trailing stuff
-# need a way to skip to the start of the next stream.
-# check that "tell" works ok
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "oneshot.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+BEGIN {
+ plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" )
+ if $] < 5.005 ;
+
+
+ # use Test::NoWarnings, if available
+ my $extra = 0 ;
+ $extra = 1
+ if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
+
+ plan tests => 70 + $extra ;
+
+ use_ok('IO::Compress::Gzip', qw($GzipError)) ;
+ use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
+
+
+}
+
+
+sub gzipGetHeader
+{
+ my $in = shift;
+ my $content = shift ;
+ my %opts = @_ ;
+
+ my $out ;
+ my $got ;
+
+ ok IO::Compress::Gzip::gzip($in, \$out, %opts), " gzip ok" ;
+ ok IO::Uncompress::Gunzip::gunzip(\$out, \$got), " gunzip ok"
+ or diag $GunzipError ;
+ is $got, $content, " got expected content" ;
+
+ my $gunz = new IO::Uncompress::Gunzip \$out, Strict => 0
+ or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ;
+ ok $gunz, " Created IO::Uncompress::Gunzip object";
+ my $hdr = $gunz->getHeaderInfo();
+ ok $hdr, " got Header info";
+ my $uncomp ;
+ ok $gunz->read($uncomp), " read ok" ;
+ is $uncomp, $content, " got expected content";
+ ok $gunz->close, " closed ok" ;
+
+ return $hdr ;
+
+}
+
+{
+ title "Check gzip header default NAME & MTIME settings" ;
+
+ my $lex = new LexFile my $file1;
+
+ my $content = "hello ";
+ my $hdr ;
+ my $mtime ;
+
+ writeFile($file1, $content);
+ $mtime = (stat($file1))[8];
+ # make sure that the gzip file isn't created in the same
+ # second as the input file
+ sleep 3 ;
+ $hdr = gzipGetHeader($file1, $content);
+
+ is $hdr->{Name}, $file1, " Name is '$file1'";
+ is $hdr->{Time}, $mtime, " Time is ok";
+
+ title "Override Name" ;
+
+ writeFile($file1, $content);
+ $mtime = (stat($file1))[8];
+ sleep 3 ;
+ $hdr = gzipGetHeader($file1, $content, Name => "abcde");
+
+ is $hdr->{Name}, "abcde", " Name is 'abcde'" ;
+ is $hdr->{Time}, $mtime, " Time is ok";
+
+ title "Override Time" ;
+
+ writeFile($file1, $content);
+ $hdr = gzipGetHeader($file1, $content, Time => 1234);
+
+ is $hdr->{Name}, $file1, " Name is '$file1'" ;
+ is $hdr->{Time}, 1234, " Time is 1234";
+
+ title "Override Name and Time" ;
+
+ writeFile($file1, $content);
+ $hdr = gzipGetHeader($file1, $content, Time => 4321, Name => "abcde");
+
+ is $hdr->{Name}, "abcde", " Name is 'abcde'" ;
+ is $hdr->{Time}, 4321, " Time is 4321";
+
+ title "Filehandle doesn't have default Name or Time" ;
+ my $fh = new IO::File "< $file1"
+ or diag "Cannot open '$file1': $!\n" ;
+ sleep 3 ;
+ my $before = time ;
+ $hdr = gzipGetHeader($fh, $content);
+ my $after = time ;
+
+ ok ! defined $hdr->{Name}, " Name is undef";
+ cmp_ok $hdr->{Time}, '>=', $before, " Time is ok";
+ cmp_ok $hdr->{Time}, '<=', $after, " Time is ok";
+
+ $fh->close;
+
+ title "Buffer doesn't have default Name or Time" ;
+ my $buffer = $content;
+ $before = time ;
+ $hdr = gzipGetHeader(\$buffer, $content);
+ $after = time ;
+
+ ok ! defined $hdr->{Name}, " Name is undef";
+ cmp_ok $hdr->{Time}, '>=', $before, " Time is ok";
+ cmp_ok $hdr->{Time}, '<=', $after, " Time is ok";
+}
+
+# TODO add more error cases
+
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "oneshot.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "oneshot.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+BEGIN {
+ plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" )
+ if $] < 5.005 ;
+
+
+ # use Test::NoWarnings, if available
+ my $extra = 0 ;
+ $extra = 1
+ if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
+
+ plan tests => 95 + $extra ;
+
+ use_ok('IO::Compress::Zip', qw(zip $ZipError)) ;
+ use_ok('IO::Uncompress::Unzip', qw(unzip $UnzipError)) ;
+
+
+}
+
+
+sub zipGetHeader
+{
+ my $in = shift;
+ my $content = shift ;
+ my %opts = @_ ;
+
+ my $out ;
+ my $got ;
+
+ ok zip($in, \$out, %opts), " zip ok" ;
+ ok unzip(\$out, \$got), " unzip ok"
+ or diag $UnzipError ;
+ is $got, $content, " got expected content" ;
+
+ my $gunz = new IO::Uncompress::Unzip \$out, Strict => 0
+ or diag "UnzipError is $IO::Uncompress::Unzip::UnzipError" ;
+ ok $gunz, " Created IO::Uncompress::Unzip object";
+ my $hdr = $gunz->getHeaderInfo();
+ ok $hdr, " got Header info";
+ my $uncomp ;
+ ok $gunz->read($uncomp), " read ok" ;
+ is $uncomp, $content, " got expected content";
+ ok $gunz->close, " closed ok" ;
+
+ return $hdr ;
+
+}
+
+{
+ title "Check zip header default NAME & MTIME settings" ;
+
+ my $lex = new LexFile my $file1;
+
+ my $content = "hello ";
+ my $hdr ;
+ my $mtime ;
+
+ writeFile($file1, $content);
+ $mtime = (stat($file1))[8];
+ # make sure that the zip file isn't created in the same
+ # second as the input file
+ sleep 3 ;
+ $hdr = zipGetHeader($file1, $content);
+
+ is $hdr->{Name}, $file1, " Name is '$file1'";
+ is $hdr->{Time}>>1, $mtime>>1, " Time is ok";
+
+ title "Override Name" ;
+
+ writeFile($file1, $content);
+ $mtime = (stat($file1))[8];
+ sleep 3 ;
+ $hdr = zipGetHeader($file1, $content, Name => "abcde");
+
+ is $hdr->{Name}, "abcde", " Name is 'abcde'" ;
+ is $hdr->{Time} >> 1, $mtime >> 1, " Time is ok";
+
+ title "Override Time" ;
+
+ writeFile($file1, $content);
+ my $useTime = time + 2000 ;
+ $hdr = zipGetHeader($file1, $content, Time => $useTime);
+
+ is $hdr->{Name}, $file1, " Name is '$file1'" ;
+ is $hdr->{Time} >> 1 , $useTime >> 1 , " Time is $useTime";
+
+ title "Override Name and Time" ;
+
+ $useTime = time + 5000 ;
+ writeFile($file1, $content);
+ $hdr = zipGetHeader($file1, $content, Time => $useTime, Name => "abcde");
+
+ is $hdr->{Name}, "abcde", " Name is 'abcde'" ;
+ is $hdr->{Time} >> 1 , $useTime >> 1 , " Time is $useTime";
+
+ title "Filehandle doesn't have default Name or Time" ;
+ my $fh = new IO::File "< $file1"
+ or diag "Cannot open '$file1': $!\n" ;
+ sleep 3 ;
+ my $before = time ;
+ $hdr = zipGetHeader($fh, $content);
+ my $after = time ;
+
+ ok ! defined $hdr->{Name}, " Name is undef";
+ cmp_ok $hdr->{Time} >> 1, '>=', $before >> 1, " Time is ok";
+ cmp_ok $hdr->{Time} >> 1, '<=', $after >> 1, " Time is ok";
+
+ $fh->close;
+
+ title "Buffer doesn't have default Name or Time" ;
+ my $buffer = $content;
+ $before = time ;
+ $hdr = zipGetHeader(\$buffer, $content);
+ $after = time ;
+
+ ok ! defined $hdr->{Name}, " Name is undef";
+ cmp_ok $hdr->{Time} >> 1, '>=', $before >> 1, " Time is ok";
+ cmp_ok $hdr->{Time} >> 1, '<=', $after >> 1, " Time is ok";
+}
+
+for my $stream (0, 1)
+{
+ for my $store (0, 8)
+ {
+ title "Stream $stream, Store $store";
+
+ my $lex = new LexFile my $file1;
+
+ my $content = "hello ";
+ writeFile($file1, $content);
+
+ ok zip(\$content => $file1 , Store => !$store, Stream => $stream), " zip ok"
+ or diag $ZipError ;
+
+ my $got ;
+ if ($stream && ! $store) {
+ #eval ' unzip($file1 => \$got) ';
+ ok ! unzip($file1 => \$got), " unzip fails";
+ like $UnzipError, "/Streamed Stored content not supported/",
+ " Streamed Stored content not supported";
+ next ;
+ }
+
+ ok unzip($file1 => \$got), " unzip ok"
+ or diag $UnzipError ;
+
+ is $got, $content, " content ok";
+
+ my $u = new IO::Uncompress::Unzip $file1
+ or diag $ZipError ;
+
+ my $hdr = $u->getHeaderInfo();
+ ok $hdr, " got header";
+
+ is $hdr->{Stream}, $stream, " stream is $stream" ;
+ is $hdr->{MethodID}, $store, " MethodID is $store" ;
+ }
+}
+
+# TODO add more error cases
+
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "oneshot.pl" ;
+run();
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = ("../lib", "lib");
- }
-}
-
-use lib 't';
-use strict;
-use warnings;
-use bytes;
-
-use Test::More ;
-use ZlibTestUtils;
-
-BEGIN {
- plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" )
- if $] < 5.005 ;
-
-
- # use Test::NoWarnings, if available
- my $extra = 0 ;
- $extra = 1
- if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
-
- plan tests => 2462 + $extra ;
-
- use_ok('Compress::Zlib', 2) ;
-
- use_ok('IO::Compress::Gzip', qw($GzipError)) ;
- use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
-
- use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
- use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
-
- use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
- use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
-
- use_ok('IO::Uncompress::AnyInflate', qw(anyinflate $AnyInflateError)) ;
-
-}
-
-
-# Check zlib_version and ZLIB_VERSION are the same.
-is Compress::Zlib::zlib_version, ZLIB_VERSION,
- "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
-
-
-
-foreach my $bit ('IO::Compress::Gzip',
- 'IO::Uncompress::Gunzip',
- 'IO::Compress::Deflate',
- 'IO::Uncompress::Inflate',
- 'IO::Compress::RawDeflate',
- 'IO::Uncompress::RawInflate',
- 'IO::Uncompress::AnyInflate',
- )
-{
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
-
- title "Testing $TopType Error Cases";
-
- my $a;
- my $x ;
-
- eval { $a = $Func->(\$a => \$x, Fred => 1) ;} ;
- like $@, mkErr("^$TopType: unknown key value\\(s\\) Fred"), ' Illegal Parameters';
-
- eval { $a = $Func->() ;} ;
- like $@, mkErr("^$TopType: expected at least 1 parameters"), ' No Parameters';
-
- eval { $a = $Func->(\$x, \1) ;} ;
- like $@, mkErr("^$TopType: output buffer is read-only"), ' Output is read-only' ;
-
- my $in ;
- eval { $a = $Func->($in, \$x) ;} ;
- like $@, mkErr("^$TopType: input filename is undef or null string"),
- ' Input filename undef' ;
-
- $in = '';
- eval { $a = $Func->($in, \$x) ;} ;
- like $@, mkErr("^$TopType: input filename is undef or null string"),
- ' Input filename empty' ;
-
- my $lex1 = new LexFile my $in1 ;
- writeFile($in1, "abc");
- my $out = $in1 ;
- eval { $a = $Func->($in1, $out) ;} ;
- like $@, mkErr("^$TopType: input and output filename are identical"),
- ' Input and Output filename are the same';
-
- eval { $a = $Func->(\$in, \$in) ;} ;
- like $@, mkErr("^$TopType: input and output buffer are identical"),
- ' Input and Output buffer are the same';
-
- my $lex = new LexFile my $out_file ;
- open OUT, ">$out_file" ;
- eval { $a = $Func->(\*OUT, \*OUT) ;} ;
- like $@, mkErr("^$TopType: input and output handle are identical"),
- ' Input and Output handle are the same';
-
- close OUT;
- is -s $out_file, 0, " File zero length" ;
- {
- my %x = () ;
- my $object = bless \%x, "someClass" ;
-
- # Buffer not a scalar reference
- #eval { $a = $Func->(\$x, \%x) ;} ;
- eval { $a = $Func->(\$x, $object) ;} ;
- like $@, mkErr("^$TopType: illegal output parameter"),
- ' Bad Output Param';
-
-
- #eval { $a = $Func->(\%x, \$x) ;} ;
- eval { $a = $Func->($object, \$x) ;} ;
- like $@, mkErr("^$TopType: illegal input parameter"),
- ' Bad Input Param';
- }
-
- my $filename = 'abc.def';
- ok ! -e $filename, " input file '$filename' does not exist";
- $a = $Func->($filename, \$x) ;
- is $a, undef, " $TopType returned undef";
- like $$Error, "/^input file '$filename' does not exist\$/", " input File '$filename' does not exist";
-
- $filename = '/tmp/abd/abc.def';
- ok ! -e $filename, " output File '$filename' does not exist";
- $a = $Func->(\$x, $filename) ;
- is $a, undef, " $TopType returned undef";
- like $$Error, ("/^(cannot open file '$filename'|input file '$filename' does not exist):/"), " output File '$filename' does not exist";
-
- $a = $Func->(\$x, '<abc>') ;
- is $a, undef, " $TopType returned undef";
- like $$Error, "/Need input fileglob for outout fileglob/",
- ' Output fileglob with no input fileglob';
-
- $a = $Func->('<abc)>', '<abc>') ;
- is $a, undef, " $TopType returned undef";
- like $$Error, "/Unmatched \\) in input fileglob/",
- " Unmatched ) in input fileglob";
-}
-
-foreach my $bit ('IO::Uncompress::Gunzip',
- 'IO::Uncompress::Inflate',
- 'IO::Uncompress::RawInflate',
- 'IO::Uncompress::AnyInflate',
- )
-{
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
-
- my $data = "mary had a little lamb" ;
- my $keep = $data ;
-
- for my $trans ( 0, 1)
- {
- title "Non-compressed data with $TopType, Transparent => $trans ";
- my $a;
- my $x ;
- my $out = '' ;
-
- $a = $Func->(\$data, \$out, Transparent => $trans) ;
-
- is $data, $keep, " Input buffer not changed" ;
-
- if ($trans)
- {
- ok $a, " $TopType returned true" ;
- is $out, $data, " got expected output" ;
- ok ! $$Error, " no error [$$Error]" ;
- }
- else
- {
- ok ! $a, " $TopType returned false" ;
- #like $$Error, '/xxx/', " error" ;
- ok $$Error, " error is '$$Error'" ;
- }
- }
-}
-
-foreach my $bit ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
- my $TopTypeInverse = getInverse($bit);
- my $FuncInverse = getTopFuncRef($TopTypeInverse);
- my $ErrorInverse = getErrorRef($TopTypeInverse);
-
- title "$TopTypeInverse - corrupt data";
-
- my $data = "abcd" x 100 ;
- my $out;
-
- ok $Func->(\$data, \$out), " $TopType ok";
-
- # corrupt the compressed data
- #substr($out, -10, 10) = "x" x 10 ;
- substr($out, int(length($out)/3), 10) = 'abcdeabcde';
-
- my $result;
- ok ! $FuncInverse->(\$out => \$result, Transparent => 0), " $TopTypeInverse ok";
- ok $$ErrorInverse, " Got error '$$ErrorInverse'" ;
-
- #is $result, $data, " data ok";
-
- ok ! anyinflate(\$out => \$result, Transparent => 0), " anyinflate ok";
- ok $AnyInflateError, " Got error '$AnyInflateError'" ;
-}
-
-
-foreach my $bit ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
- my $TopTypeInverse = getInverse($bit);
- my $FuncInverse = getTopFuncRef($TopTypeInverse);
-
- for my $append ( 1, 0 )
- {
- my $already = '';
- $already = 'abcde' if $append ;
-
- for my $buffer ( undef, '', "abcde" )
- {
-
- my $disp_content = defined $buffer ? $buffer : '<undef>' ;
-
- my $keep = $buffer;
- my $out_file = "abcde.out";
- my $in_file = "abcde.in";
-
- {
- title "$TopType - From Buff to Buff content '$disp_content' Append $append" ;
-
- my $output = $already;
- ok &$Func(\$buffer, \$output, Append => $append), ' Compressed ok' ;
-
- is $keep, $buffer, " Input buffer not changed" ;
- my $got = anyUncompress(\$output, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $got, $buffer, " Uncompressed matches original";
-
- }
-
- {
- title "$TopType - From Buff to Array Ref content '$disp_content' Append $append" ;
-
- my @output = ('first') ;
- ok &$Func(\$buffer, \@output, Append => $append), ' Compressed ok' ;
-
- is $output[0], 'first', " Array[0] unchanged";
- is $keep, $buffer, " Input buffer not changed" ;
- my $got = anyUncompress($output[1]);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $got, $buffer, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Array Ref to Array Ref content '$disp_content' Append $append" ;
-
- my @output = ('first') ;
- my @input = ( \$buffer);
- ok &$Func(\@input, \@output, Append => $append), ' Compressed ok' ;
-
- is $output[0], 'first', " Array[0] unchanged";
- is $keep, $buffer, " Input buffer not changed" ;
- my $got = anyUncompress($output[1]);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $got, $buffer, " Uncompressed matches original";
-
- }
-
- {
- title "$TopType - From Buff to Filename content '$disp_content' Append $append" ;
-
- my $lex = new LexFile($out_file) ;
- ok ! -e $out_file, " Output file does not exist";
- writeFile($out_file, $already);
-
- ok &$Func(\$buffer, $out_file, Append => $append), ' Compressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $got = anyUncompress($out_file, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $got, $buffer, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Buff to Handle content '$disp_content' Append $append" ;
-
- my $lex = new LexFile($out_file) ;
-
- ok ! -e $out_file, " Output file does not exist";
- writeFile($out_file, $already);
- my $of = new IO::File ">>$out_file" ;
- ok $of, " Created output filehandle" ;
-
- ok &$Func(\$buffer, $of, AutoClose => 1, Append => $append), ' Compressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $got = anyUncompress($out_file, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $got, $buffer, " Uncompressed matches original";
- }
-
-
- {
- title "$TopType - From Filename to Filename content '$disp_content' Append $append" ;
-
- my $lex = new LexFile($in_file, $out_file) ;
- writeFile($in_file, $buffer);
-
- ok ! -e $out_file, " Output file does not exist";
- writeFile($out_file, $already);
-
- ok &$Func($in_file => $out_file, Append => $append), ' Compressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $got = anyUncompress($out_file, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $got, $buffer, " Uncompressed matches original";
-
- }
-
- {
- title "$TopType - From Filename to Handle content '$disp_content' Append $append" ;
-
- my $lex = new LexFile($in_file, $out_file) ;
- writeFile($in_file, $buffer);
-
- ok ! -e $out_file, " Output file does not exist";
- writeFile($out_file, $already);
- my $out = new IO::File ">>$out_file" ;
-
- ok &$Func($in_file, $out, AutoClose => 1, Append => $append), ' Compressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $got = anyUncompress($out_file, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $got, $buffer, " Uncompressed matches original";
-
- }
-
- {
- title "$TopType - From Filename to Buffer content '$disp_content' Append $append" ;
-
- my $lex = new LexFile($in_file, $out_file) ;
- writeFile($in_file, $buffer);
-
- my $out = $already;
-
- ok &$Func($in_file => \$out, Append => $append), ' Compressed ok' ;
-
- my $got = anyUncompress(\$out, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $got, $buffer, " Uncompressed matches original";
-
- }
-
- {
- title "$TopType - From Handle to Filename content '$disp_content' Append $append" ;
-
- my $lex = new LexFile($in_file, $out_file) ;
- writeFile($in_file, $buffer);
- my $in = new IO::File "<$in_file" ;
-
- ok ! -e $out_file, " Output file does not exist";
- writeFile($out_file, $already);
-
- ok &$Func($in, $out_file, Append => $append), ' Compressed ok'
- or diag "error is $GzipError" ;
-
- ok -e $out_file, " Created output file";
- my $got = anyUncompress($out_file, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $buffer, $got, " Uncompressed matches original";
-
- }
-
- {
- title "$TopType - From Handle to Handle content '$disp_content' Append $append" ;
-
- my $lex = new LexFile($in_file, $out_file) ;
- writeFile($in_file, $buffer);
- my $in = new IO::File "<$in_file" ;
-
- ok ! -e $out_file, " Output file does not exist";
- writeFile($out_file, $already);
- my $out = new IO::File ">>$out_file" ;
-
- ok &$Func($in, $out, AutoClose => 1, Append => $append), ' Compressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $got = anyUncompress($out_file, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $buffer, $got, " Uncompressed matches original";
-
- }
-
- {
- title "$TopType - From Handle to Buffer content '$disp_content' Append $append" ;
-
- my $lex = new LexFile($in_file, $out_file) ;
- writeFile($in_file, $buffer);
- my $in = new IO::File "<$in_file" ;
-
- my $out = $already ;
-
- ok &$Func($in, \$out, Append => $append), ' Compressed ok' ;
-
- my $got = anyUncompress(\$out, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $buffer, $got, " Uncompressed matches original";
-
- }
-
- {
- title "$TopType - From stdin (via '-') to Buffer content '$disp_content' Append $append" ;
-
- my $lex = new LexFile($in_file, $out_file) ;
- writeFile($in_file, $buffer);
-
- open(SAVEIN, "<&STDIN");
- my $dummy = fileno SAVEIN ;
- ok open(STDIN, "<$in_file"), " redirect STDIN";
-
- my $out = $already;
-
- ok &$Func('-', \$out, Append => $append), ' Compressed ok'
- or diag $$Error ;
-
- open(STDIN, "<&SAVEIN");
-
- my $got = anyUncompress(\$out, $already);
- $got = undef if ! defined $buffer && $got eq '' ;
- is $buffer, $got, " Uncompressed matches original";
-
- }
-
- }
- }
-}
-
-foreach my $bit ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
-
- my $TopTypeInverse = getInverse($bit);
- my $FuncInverse = getTopFuncRef($TopTypeInverse);
-
- my ($file1, $file2) = ("file1", "file2");
- my $lex = new LexFile($file1, $file2) ;
-
- writeFile($file1, "data1");
- writeFile($file2, "data2");
- my $of = new IO::File "<$file1" ;
- ok $of, " Created output filehandle" ;
-
- my @input = ( undef, "", $file2, \undef, \'', \"abcde", $of) ;
- my @expected = ("", "", $file2, "", "", "abcde", "data1");
- my @uexpected = ("", "", "data2", "", "", "abcde", "data1");
-
- my @keep = @input ;
-
- {
- title "$TopType - From Array Ref to Array Ref" ;
-
- my @output = ('first') ;
- ok &$Func(\@input, \@output, AutoClose => 0), ' Compressed ok' ;
-
- is $output[0], 'first', " Array[0] unchanged";
-
- is_deeply \@input, \@keep, " Input array not changed" ;
- my @got = shift @output;
- foreach (@output) { push @got, anyUncompress($_) }
-
- is_deeply \@got, ['first', @expected], " Got Expected uncompressed data";
-
- }
-
- {
- title "$TopType - From Array Ref to Buffer" ;
-
- # rewind the filehandle
- $of->open("<$file1") ;
-
- my $output ;
- ok &$Func(\@input, \$output, AutoClose => 0), ' Compressed ok' ;
-
- my $got = anyUncompress(\$output);
-
- is $got, join('', @expected), " Got Expected uncompressed data";
- }
-
- {
- title "$TopType - From Array Ref to Filename" ;
-
- my ($file3) = ("file3");
- my $lex = new LexFile($file3) ;
-
- # rewind the filehandle
- $of->open("<$file1") ;
-
- my $output ;
- ok &$Func(\@input, $file3, AutoClose => 0), ' Compressed ok' ;
-
- my $got = anyUncompress($file3);
-
- is $got, join('', @expected), " Got Expected uncompressed data";
- }
-
- {
- title "$TopType - From Array Ref to Filehandle" ;
-
- my ($file3) = ("file3");
- my $lex = new LexFile($file3) ;
-
- my $fh3 = new IO::File ">$file3";
-
- # rewind the filehandle
- $of->open("<$file1") ;
-
- my $output ;
- ok &$Func(\@input, $fh3, AutoClose => 0), ' Compressed ok' ;
-
- $fh3->close();
-
- my $got = anyUncompress($file3);
-
- is $got, join('', @expected), " Got Expected uncompressed data";
- }
-}
-
-foreach my $bit ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
-
- my $TopTypeInverse = getInverse($bit);
- my $FuncInverse = getTopFuncRef($TopTypeInverse);
-
- my @inFiles = map { "in$_.tmp" } 1..4;
- my @outFiles = map { "out$_.tmp" } 1..4;
- my $lex = new LexFile(@inFiles, @outFiles);
-
- writeFile($_, "data $_") foreach @inFiles ;
-
- {
- title "$TopType - Hash Ref: to filename" ;
-
- my $output ;
- ok &$Func( { $inFiles[0] => $outFiles[0],
- $inFiles[1] => $outFiles[1],
- $inFiles[2] => $outFiles[2] } ), ' Compressed ok' ;
-
- foreach (0 .. 2)
- {
- my $got = anyUncompress($outFiles[$_]);
- is $got, "data $inFiles[$_]", " Uncompressed $_ matches original";
- }
- }
-
- {
- title "$TopType - Hash Ref: to buffer" ;
-
- my @buffer ;
- ok &$Func( { $inFiles[0] => \$buffer[0],
- $inFiles[1] => \$buffer[1],
- $inFiles[2] => \$buffer[2] } ), ' Compressed ok' ;
-
- foreach (0 .. 2)
- {
- my $got = anyUncompress(\$buffer[$_]);
- is $got, "data $inFiles[$_]", " Uncompressed $_ matches original";
- }
- }
-
- {
- title "$TopType - Hash Ref: to undef" ;
-
- my @buffer ;
- my %hash = ( $inFiles[0] => undef,
- $inFiles[1] => undef,
- $inFiles[2] => undef,
- );
-
- ok &$Func( \%hash ), ' Compressed ok' ;
-
- foreach (keys %hash)
- {
- my $got = anyUncompress(\$hash{$_});
- is $got, "data $_", " Uncompressed $_ matches original";
- }
- }
-
- {
- title "$TopType - Filename to Hash Ref" ;
-
- my %output ;
- ok &$Func( $inFiles[0] => \%output), ' Compressed ok' ;
-
- is keys %output, 1, " one pair in hash" ;
- my ($k, $v) = each %output;
- is $k, $inFiles[0], " key is '$inFiles[0]'";
- my $got = anyUncompress($v);
- is $got, "data $inFiles[0]", " Uncompressed matches original";
- }
-
- {
- title "$TopType - File Glob to Hash Ref" ;
-
- my %output ;
- ok &$Func( '<in*.tmp>' => \%output), ' Compressed ok' ;
-
- is keys %output, 4, " four pairs in hash" ;
- foreach my $fil (@inFiles)
- {
- ok exists $output{$fil}, " key '$fil' exists" ;
- my $got = anyUncompress($output{$fil});
- is $got, "data $fil", " Uncompressed matches original";
- }
- }
-
-
-# if (0)
-# {
-# title "$TopType - Hash Ref to Array Ref" ;
-#
-# my @output = ('first') ;
-# ok &$Func( { \@input, \@output } , AutoClose => 0), ' Compressed ok' ;
-#
-# is $output[0], 'first', " Array[0] unchanged";
-#
-# is_deeply \@input, \@keep, " Input array not changed" ;
-# my @got = shift @output;
-# foreach (@output) { push @got, anyUncompress($_) }
-#
-# is_deeply \@got, ['first', @expected], " Got Expected uncompressed data";
-#
-# }
-#
-# if (0)
-# {
-# title "$TopType - From Array Ref to Buffer" ;
-#
-# # rewind the filehandle
-# $of->open("<$file1") ;
-#
-# my $output ;
-# ok &$Func(\@input, \$output, AutoClose => 0), ' Compressed ok' ;
-#
-# my $got = anyUncompress(\$output);
-#
-# is $got, join('', @expected), " Got Expected uncompressed data";
-# }
-#
-# if (0)
-# {
-# title "$TopType - From Array Ref to Filename" ;
-#
-# my ($file3) = ("file3");
-# my $lex = new LexFile($file3) ;
-#
-# # rewind the filehandle
-# $of->open("<$file1") ;
-#
-# my $output ;
-# ok &$Func(\@input, $file3, AutoClose => 0), ' Compressed ok' ;
-#
-# my $got = anyUncompress($file3);
-#
-# is $got, join('', @expected), " Got Expected uncompressed data";
-# }
-#
-# if (0)
-# {
-# title "$TopType - From Array Ref to Filehandle" ;
-#
-# my ($file3) = ("file3");
-# my $lex = new LexFile($file3) ;
-#
-# my $fh3 = new IO::File ">$file3";
-#
-# # rewind the filehandle
-# $of->open("<$file1") ;
-#
-# my $output ;
-# ok &$Func(\@input, $fh3, AutoClose => 0), ' Compressed ok' ;
-#
-# $fh3->close();
-#
-# my $got = anyUncompress($file3);
-#
-# is $got, join('', @expected), " Got Expected uncompressed data";
-# }
-}
-
-foreach my $bit ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
-
- for my $files ( [qw(a1)], [qw(a1 a2 a3)] )
- {
-
- my $tmpDir1 = 'tmpdir1';
- my $tmpDir2 = 'tmpdir2';
- my $lex = new LexDir($tmpDir1, $tmpDir2) ;
-
- mkdir $tmpDir1, 0777;
- mkdir $tmpDir2, 0777;
-
- ok -d $tmpDir1, " Temp Directory $tmpDir1 exists";
- #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist";
-
- my @files = map { "$tmpDir1/$_.tmp" } @$files ;
- foreach (@files) { writeFile($_, "abc $_") }
-
- my @expected = map { "abc $_" } @files ;
- my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ;
-
- {
- title "$TopType - From FileGlob to FileGlob files [@$files]" ;
-
- ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' Compressed ok'
- or diag $$Error ;
-
- my @copy = @expected;
- for my $file (@outFiles)
- {
- is anyUncompress($file), shift @copy, " got expected from $file" ;
- }
-
- is @copy, 0, " got all files";
- }
-
- {
- title "$TopType - From FileGlob to Array files [@$files]" ;
-
- my @buffer = ('first') ;
- ok &$Func("<$tmpDir1/a*.tmp>" => \@buffer), ' Compressed ok'
- or diag $$Error ;
-
- is shift @buffer, 'first';
-
- my @copy = @expected;
- for my $buffer (@buffer)
- {
- is anyUncompress($buffer), shift @copy, " got expected " ;
- }
-
- is @copy, 0, " got all files";
- }
-
- {
- title "$TopType - From FileGlob to Buffer files [@$files]" ;
-
- my $buffer ;
- ok &$Func("<$tmpDir1/a*.tmp>" => \$buffer), ' Compressed ok'
- or diag $$Error ;
-
- #hexDump(\$buffer);
-
- my $got = anyUncompress([ \$buffer, MultiStream => 1 ]);
-
- is $got, join("", @expected), " got expected" ;
- }
-
- {
- title "$TopType - From FileGlob to Filename files [@$files]" ;
-
- my $filename = "abcde";
- my $lex = new LexFile($filename) ;
-
- ok &$Func("<$tmpDir1/a*.tmp>" => $filename), ' Compressed ok'
- or diag $$Error ;
-
- #hexDump(\$buffer);
-
- my $got = anyUncompress([$filename, MultiStream => 1]);
-
- is $got, join("", @expected), " got expected" ;
- }
-
- {
- title "$TopType - From FileGlob to Filehandle files [@$files]" ;
-
- my $filename = "abcde";
- my $lex = new LexFile($filename) ;
- my $fh = new IO::File ">$filename";
-
- ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1), ' Compressed ok'
- or diag $$Error ;
-
- #hexDump(\$buffer);
-
- my $got = anyUncompress([$filename, MultiStream => 1]);
-
- is $got, join("", @expected), " got expected" ;
- }
- }
-
-}
-
-foreach my $bit ('IO::Uncompress::Gunzip',
- 'IO::Uncompress::Inflate',
- 'IO::Uncompress::RawInflate',
- 'IO::Uncompress::AnyInflate',
- )
-{
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
-
- my $buffer = "abcde" ;
- my $buffer2 = "ABCDE" ;
- my $keep_orig = $buffer;
-
- my $comp = compressBuffer($TopType, $buffer) ;
- my $comp2 = compressBuffer($TopType, $buffer2) ;
- my $keep_comp = $comp;
-
- my $incumbent = "incumbent data" ;
-
- for my $append (0, 1)
- {
- my $expected = $buffer ;
- $expected = $incumbent . $buffer if $append ;
-
- {
- title "$TopType - From Buff to Buff, Append($append)" ;
-
- my $output ;
- $output = $incumbent if $append ;
- ok &$Func(\$comp, \$output, Append => $append), ' Uncompressed ok' ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $output, $expected, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Buff to Array, Append($append)" ;
-
- my @output = ('first');
- #$output = $incumbent if $append ;
- ok &$Func(\$comp, \@output, Append => $append), ' Uncompressed ok' ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $output[0], 'first', " Uncompressed matches original";
- is ${ $output[1] }, $buffer, " Uncompressed matches original"
- or diag $output[1] ;
- is @output, 2, " only 2 elements in the array" ;
- }
-
- {
- title "$TopType - From Buff to Filename, Append($append)" ;
-
- my $out_file = "abcde";
- my $lex = new LexFile($out_file) ;
- if ($append)
- { writeFile($out_file, $incumbent) }
- else
- { ok ! -e $out_file, " Output file does not exist" }
-
- ok &$Func(\$comp, $out_file, Append => $append), ' Uncompressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $content = readFile($out_file) ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $content, $expected, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Buff to Handle, Append($append)" ;
-
- my $out_file = "abcde";
- my $lex = new LexFile($out_file) ;
- my $of ;
- if ($append) {
- writeFile($out_file, $incumbent) ;
- $of = new IO::File "+< $out_file" ;
- }
- else {
- ok ! -e $out_file, " Output file does not exist" ;
- $of = new IO::File "> $out_file" ;
- }
- isa_ok $of, 'IO::File', ' $of' ;
-
- ok &$Func(\$comp, $of, Append => $append, AutoClose => 1), ' Uncompressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $content = readFile($out_file) ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $content, $expected, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Filename to Filename, Append($append)" ;
-
- my $out_file = "abcde.out";
- my $in_file = "abcde.in";
- my $lex = new LexFile($in_file, $out_file) ;
- if ($append)
- { writeFile($out_file, $incumbent) }
- else
- { ok ! -e $out_file, " Output file does not exist" }
-
- writeFile($in_file, $comp);
-
- ok &$Func($in_file, $out_file, Append => $append), ' Uncompressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $content = readFile($out_file) ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $content, $expected, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Filename to Handle, Append($append)" ;
-
- my $out_file = "abcde.out";
- my $in_file = "abcde.in";
- my $lex = new LexFile($in_file, $out_file) ;
- my $out ;
- if ($append) {
- writeFile($out_file, $incumbent) ;
- $out = new IO::File "+< $out_file" ;
- }
- else {
- ok ! -e $out_file, " Output file does not exist" ;
- $out = new IO::File "> $out_file" ;
- }
- isa_ok $out, 'IO::File', ' $out' ;
-
- writeFile($in_file, $comp);
-
- ok &$Func($in_file, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $content = readFile($out_file) ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $content, $expected, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Filename to Buffer, Append($append)" ;
-
- my $in_file = "abcde.in";
- my $lex = new LexFile($in_file) ;
- writeFile($in_file, $comp);
-
- my $output ;
- $output = $incumbent if $append ;
-
- ok &$Func($in_file, \$output, Append => $append), ' Uncompressed ok' ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $output, $expected, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Handle to Filename, Append($append)" ;
-
- my $out_file = "abcde.out";
- my $in_file = "abcde.in";
- my $lex = new LexFile($in_file, $out_file) ;
- if ($append)
- { writeFile($out_file, $incumbent) }
- else
- { ok ! -e $out_file, " Output file does not exist" }
-
- writeFile($in_file, $comp);
- my $in = new IO::File "<$in_file" ;
-
- ok &$Func($in, $out_file, Append => $append), ' Uncompressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $content = readFile($out_file) ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $content, $expected, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Handle to Handle, Append($append)" ;
-
- my $out_file = "abcde.out";
- my $in_file = "abcde.in";
- my $lex = new LexFile($in_file, $out_file) ;
- my $out ;
- if ($append) {
- writeFile($out_file, $incumbent) ;
- $out = new IO::File "+< $out_file" ;
- }
- else {
- ok ! -e $out_file, " Output file does not exist" ;
- $out = new IO::File "> $out_file" ;
- }
- isa_ok $out, 'IO::File', ' $out' ;
-
- writeFile($in_file, $comp);
- my $in = new IO::File "<$in_file" ;
-
- ok &$Func($in, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ;
-
- ok -e $out_file, " Created output file";
- my $content = readFile($out_file) ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $content, $expected, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From Filename to Buffer, Append($append)" ;
-
- my $in_file = "abcde.in";
- my $lex = new LexFile($in_file) ;
- writeFile($in_file, $comp);
- my $in = new IO::File "<$in_file" ;
-
- my $output ;
- $output = $incumbent if $append ;
-
- ok &$Func($in, \$output, Append => $append), ' Uncompressed ok' ;
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $output, $expected, " Uncompressed matches original";
- }
-
- {
- title "$TopType - From stdin (via '-') to Buffer content, Append($append) " ;
-
- my $in_file = "abcde.in";
- my $lex = new LexFile($in_file) ;
- writeFile($in_file, $comp);
-
- open(SAVEIN, "<&STDIN");
- my $dummy = fileno SAVEIN ;
- ok open(STDIN, "<$in_file"), " redirect STDIN";
-
- my $output ;
- $output = $incumbent if $append ;
-
- ok &$Func('-', \$output, Append => $append), ' Uncompressed ok'
- or diag $$Error ;
-
- open(STDIN, "<&SAVEIN");
-
- is $keep_comp, $comp, " Input buffer not changed" ;
- is $output, $expected, " Uncompressed matches original";
- }
- }
-
- {
- title "$TopType - From Handle to Buffer, InputLength" ;
-
- my $out_file = "abcde.out";
- my $in_file = "abcde.in";
- my $lex = new LexFile($in_file, $out_file) ;
- my $out ;
-
- my $expected = $buffer ;
- my $appended = 'appended';
- my $len_appended = length $appended;
- writeFile($in_file, $comp . $appended . $comp . $appended) ;
- my $in = new IO::File "<$in_file" ;
-
- ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ;
-
- is $out, $expected, " Uncompressed matches original";
-
- my $buff;
- is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok";
- is $buff, $appended, " Appended data ok";
-
- $out = '';
- ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ;
-
- is $out, $expected, " Uncompressed matches original";
-
- $buff = '';
- is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok";
- is $buff, $appended, " Appended data ok";
- }
-
- for my $stdin ('-', *STDIN) # , \*STDIN)
- {
- title "$TopType - From stdin (via $stdin) to Buffer content, InputLength" ;
-
- my $lex = new LexFile my $in_file ;
- my $expected = $buffer ;
- my $appended = 'appended';
- my $len_appended = length $appended;
- writeFile($in_file, $comp . $appended ) ;
-
- open(SAVEIN, "<&STDIN");
- my $dummy = fileno SAVEIN ;
- ok open(STDIN, "<$in_file"), " redirect STDIN";
-
- my $output ;
-
- ok &$Func($stdin, \$output, Transparent => 0, InputLength => length $comp), ' Uncompressed ok'
- or diag $$Error ;
-
- my $buff ;
- is read(STDIN, $buff, $len_appended), $len_appended, " Length of Appended data ok";
-
- is $output, $expected, " Uncompressed matches original";
- is $buff, $appended, " Appended data ok";
-
- open(STDIN, "<&SAVEIN");
- }
-}
-
-foreach my $bit ('IO::Uncompress::Gunzip',
- 'IO::Uncompress::Inflate',
- 'IO::Uncompress::RawInflate',
- 'IO::Uncompress::AnyInflate',
- )
-{
- # TODO -- Add Append mode tests
-
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
-
- my $buffer = "abcde" ;
- my $keep_orig = $buffer;
-
-
- my $null = compressBuffer($TopType, "") ;
- my $undef = compressBuffer($TopType, undef) ;
- my $comp = compressBuffer($TopType, $buffer) ;
- my $keep_comp = $comp;
-
- my $incumbent = "incumbent data" ;
-
- #my ($file1, $file2) = ("file1", "file2");
- my $lex = new LexFile(my $file1, my $file2) ;
-
- writeFile($file1, compressBuffer($TopType,"data1"));
- writeFile($file2, compressBuffer($TopType,"data2"));
-
- my $of = new IO::File "<$file1" ;
- ok $of, " Created output filehandle" ;
-
- my @input = ($file2, \$undef, \$null, \$comp, $of) ;
- my @expected = ('data2', '', '', 'abcde', 'data1');
-
- my @keep = @input ;
-
- {
- title "$TopType - From ArrayRef to Buffer" ;
-
- my $output ;
- ok &$Func(\@input, \$output, AutoClose => 0), ' UnCompressed ok' ;
-
- is $output, join('', @expected)
- }
-
- {
- title "$TopType - From ArrayRef to Filename" ;
-
- my $output = 'abc';
- my $lex = new LexFile $output;
- $of->open("<$file1") ;
-
- ok &$Func(\@input, $output, AutoClose => 0), ' UnCompressed ok' ;
-
- is readFile($output), join('', @expected)
- }
-
- {
- title "$TopType - From ArrayRef to Filehandle" ;
-
- my $output = 'abc';
- my $lex = new LexFile $output;
- my $fh = new IO::File ">$output" ;
- $of->open("<$file1") ;
-
- ok &$Func(\@input, $fh, AutoClose => 0), ' UnCompressed ok' ;
- $fh->close;
-
- is readFile($output), join('', @expected)
- }
-
- {
- title "$TopType - From Array Ref to Array Ref" ;
-
- my @output = (\'first') ;
- $of->open("<$file1") ;
- ok &$Func(\@input, \@output, AutoClose => 0), ' UnCompressed ok' ;
-
- is_deeply \@input, \@keep, " Input array not changed" ;
- is_deeply [map { defined $$_ ? $$_ : "" } @output],
- ['first', @expected],
- " Got Expected uncompressed data";
-
- }
-}
-
-foreach my $bit ('IO::Uncompress::Gunzip',
- 'IO::Uncompress::Inflate',
- 'IO::Uncompress::RawInflate',
- 'IO::Uncompress::AnyInflate',
- )
-{
- # TODO -- Add Append mode tests
-
- my $Error = getErrorRef($bit);
- my $Func = getTopFuncRef($bit);
- my $TopType = getTopFuncName($bit);
-
- my $tmpDir1 = 'tmpdir1';
- my $tmpDir2 = 'tmpdir2';
- my $lex = new LexDir($tmpDir1, $tmpDir2) ;
-
- mkdir $tmpDir1, 0777;
- mkdir $tmpDir2, 0777;
-
- ok -d $tmpDir1, " Temp Directory $tmpDir1 exists";
- #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist";
-
- my @files = map { "$tmpDir1/$_.tmp" } qw( a1 a2 a3) ;
- foreach (@files) { writeFile($_, compressBuffer($TopType, "abc $_")) }
-
- my @expected = map { "abc $_" } @files ;
- my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ;
-
- {
- title "$TopType - From FileGlob to FileGlob" ;
-
- ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' UnCompressed ok'
- or diag $$Error ;
-
- my @copy = @expected;
- for my $file (@outFiles)
- {
- is readFile($file), shift @copy, " got expected from $file" ;
- }
-
- is @copy, 0, " got all files";
- }
-
- {
- title "$TopType - From FileGlob to Arrayref" ;
-
- my @output = (\'first');
- ok &$Func("<$tmpDir1/a*.tmp>" => \@output), ' UnCompressed ok'
- or diag $$Error ;
-
- my @copy = ('first', @expected);
- for my $data (@output)
- {
- is $$data, shift @copy, " got expected data" ;
- }
-
- is @copy, 0, " got all files";
- }
-
- {
- title "$TopType - From FileGlob to Buffer" ;
-
- my $output ;
- ok &$Func("<$tmpDir1/a*.tmp>" => \$output), ' UnCompressed ok'
- or diag $$Error ;
-
- is $output, join('', @expected), " got expected uncompressed data";
- }
-
- {
- title "$TopType - From FileGlob to Filename" ;
-
- my $output = 'abc' ;
- my $lex = new LexFile $output ;
- ok ! -e $output, " $output does not exist" ;
- ok &$Func("<$tmpDir1/a*.tmp>" => $output), ' UnCompressed ok'
- or diag $$Error ;
-
- ok -e $output, " $output does exist" ;
- is readFile($output), join('', @expected), " got expected uncompressed data";
- }
-
- {
- title "$TopType - From FileGlob to Filehandle" ;
-
- my $output = 'abc' ;
- my $lex = new LexFile $output ;
- my $fh = new IO::File ">$output" ;
- ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1), ' UnCompressed ok'
- or diag $$Error ;
-
- ok -e $output, " $output does exist" ;
- is readFile($output), join('', @expected), " got expected uncompressed data";
- }
-
-}
-
-foreach my $TopType ('IO::Compress::Gzip::gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- # TODO -- add the inflate classes
- )
-{
- my $Error = getErrorRef($TopType);
- my $Func = getTopFuncRef($TopType);
- my $Name = getTopFuncName($TopType);
-
- title "More write tests" ;
-
- my $lex = new LexFile(my $file1, my $file2, my $file3) ;
-
- writeFile($file1, "F1");
- writeFile($file2, "F2");
- writeFile($file3, "F3");
-
- my @data = (
- [ '[]', "" ],
- [ '[\""]', "" ],
- [ '[\undef]', "" ],
- [ '[\"abcd"]', "abcd" ],
- [ '[\"ab", \"cd"]', "abcd" ],
-
- [ '$fh2', "F2" ],
- [ '[\"a", $fh1, \"bc"]', "aF1bc"],
- ) ;
-
-
- foreach my $data (@data)
- {
- my ($send, $get) = @$data ;
-
- my $fh1 = new IO::File "< $file1" ;
- my $fh2 = new IO::File "< $file2" ;
- my $fh3 = new IO::File "< $file3" ;
-
- title "$send";
- my $copy;
- eval "\$copy = $send";
- my $Answer ;
- ok &$Func($copy, \$Answer), " $Name ok";
-
- my $got = anyUncompress(\$Answer);
- is $got, $get, " got expected output" ;
- ok ! $$Error, " no error"
- or diag "Error is $$Error";
-
- }
-
- title "Array Input Error tests" ;
-
- @data = (
- '[[]]',
- '[[[]]]',
- '[[\"ab"], [\"cd"]]',
- ) ;
-
-
- foreach my $send (@data)
- {
- my $fh1 = new IO::File "< $file1" ;
- my $fh2 = new IO::File "< $file2" ;
- my $fh3 = new IO::File "< $file3" ;
-
- title "$send";
- my $copy;
- eval "\$copy = $send";
- my $Answer ;
- ok ! &$Func($copy, \$Answer), " $Name fails";
-
- is $$Error, "unknown input parameter", " got error message";
-
- }
-}
-
-sub gzipGetHeader
-{
- my $in = shift;
- my $content = shift ;
- my %opts = @_ ;
-
- my $out ;
- my $got ;
-
- ok IO::Compress::Gzip::gzip($in, \$out, %opts), " gzip ok" ;
- ok IO::Uncompress::Gunzip::gunzip(\$out, \$got), " gunzip ok"
- or diag $GunzipError ;
- is $got, $content, " got expected content" ;
-
- my $gunz = new IO::Uncompress::Gunzip \$out, Strict => 0
- or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ;
- ok $gunz, " Created IO::Uncompress::Gunzip object";
- my $hdr = $gunz->getHeaderInfo();
- ok $hdr, " got Header info";
- my $uncomp ;
- ok $gunz->read($uncomp), " read ok" ;
- is $uncomp, $content, " got expected content";
- ok $gunz->close, " closed ok" ;
-
- return $hdr ;
-
-}
-
-{
- title "Check gzip header default NAME & MTIME settings" ;
-
- my $lex = new LexFile my $file1;
-
- my $content = "hello ";
- my $hdr ;
- my $mtime ;
-
- writeFile($file1, $content);
- $mtime = (stat($file1))[8];
- # make sure that the gzip file isn't created in the same
- # second as the input file
- sleep 3 ;
- $hdr = gzipGetHeader($file1, $content);
-
- is $hdr->{Name}, $file1, " Name is '$file1'";
- is $hdr->{Time}, $mtime, " Time is ok";
-
- title "Override Name" ;
-
- writeFile($file1, $content);
- $mtime = (stat($file1))[8];
- sleep 3 ;
- $hdr = gzipGetHeader($file1, $content, Name => "abcde");
-
- is $hdr->{Name}, "abcde", " Name is 'abcde'" ;
- is $hdr->{Time}, $mtime, " Time is ok";
-
- title "Override Time" ;
-
- writeFile($file1, $content);
- $hdr = gzipGetHeader($file1, $content, Time => 1234);
-
- is $hdr->{Name}, $file1, " Name is '$file1'" ;
- is $hdr->{Time}, 1234, " Time is 1234";
-
- title "Override Name and Time" ;
-
- writeFile($file1, $content);
- $hdr = gzipGetHeader($file1, $content, Time => 4321, Name => "abcde");
-
- is $hdr->{Name}, "abcde", " Name is 'abcde'" ;
- is $hdr->{Time}, 4321, " Time is 4321";
-
- title "Filehandle doesn't have default Name or Time" ;
- my $fh = new IO::File "< $file1"
- or diag "Cannot open '$file1': $!\n" ;
- sleep 3 ;
- my $before = time ;
- $hdr = gzipGetHeader($fh, $content);
- my $after = time ;
-
- ok ! defined $hdr->{Name}, " Name is undef";
- cmp_ok $hdr->{Time}, '>=', $before, " Time is ok";
- cmp_ok $hdr->{Time}, '<=', $after, " Time is ok";
-
- $fh->close;
-
- title "Buffer doesn't have default Name or Time" ;
- my $buffer = $content;
- $before = time ;
- $hdr = gzipGetHeader(\$buffer, $content);
- $after = time ;
-
- ok ! defined $hdr->{Name}, " Name is undef";
- cmp_ok $hdr->{Time}, '>=', $before, " Time is ok";
- cmp_ok $hdr->{Time}, '<=', $after, " Time is ok";
-}
-
-# TODO add more error cases
-
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "destroy.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "destroy.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "destroy.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "destroy.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "tied.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "tied.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "tied.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "tied.pl" ;
+run();
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = ("../lib", "lib");
- }
-}
-
-use lib 't';
-use strict;
-use warnings;
-use bytes;
-
-use Test::More ;
-use ZlibTestUtils;
-
-our ($BadPerl);
-
-BEGIN
-{
- plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" )
- if $] < 5.005 ;
-
- # use Test::NoWarnings, if available
- my $extra = 0 ;
- $extra = 1
- if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
-
- my $tests ;
- $BadPerl = ($] >= 5.006 or $] <= 5.008) ;
-
- if ($BadPerl) {
- $tests = 731 ;
- }
- else {
- $tests = 771 ;
- }
-
- plan tests => $tests + $extra ;
-
- use_ok('Compress::Zlib', 2) ;
-
- use_ok('IO::Compress::Gzip', qw($GzipError)) ;
- use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
-
- use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
- use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
-
- use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
- use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
-}
-
-
-use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
-
-
-
-
-our ($UncompressClass);
-
-
-sub myGZreadFile
-{
- my $filename = shift ;
- my $init = shift ;
-
-
- my $fil = new $UncompressClass $filename,
- -Strict => 1,
- -Append => 1
- ;
-
- my $data ;
- $data = $init if defined $init ;
- 1 while $fil->read($data) > 0;
-
- $fil->close ;
- return $data ;
-}
-
-# Check zlib_version and ZLIB_VERSION are the same.
-is Compress::Zlib::zlib_version, ZLIB_VERSION,
- "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
-
-
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate')
-{
- next if $BadPerl ;
-
-
- title "Testing $CompressClass";
-
-
- my $x ;
- my $gz = new $CompressClass(\$x);
-
- my $buff ;
-
- eval { getc($gz) } ;
- like $@, mkErr("^getc Not Available: File opened only for output");
-
- eval { read($gz, $buff, 1) } ;
- like $@, mkErr("^read Not Available: File opened only for output");
-
- eval { <$gz> } ;
- like $@, mkErr("^readline Not Available: File opened only for output");
-
-}
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate')
-{
- next if $BadPerl;
- $UncompressClass = getInverse($CompressClass);
-
- title "Testing $UncompressClass";
-
- my $gc ;
- my $guz = new $CompressClass(\$gc);
- $guz->write("abc") ;
- $guz->close();
-
- my $x ;
- my $gz = new $UncompressClass(\$gc);
-
- my $buff ;
-
- eval { print $gz "abc" } ;
- like $@, mkErr("^print Not Available: File opened only for intput");
-
- eval { printf $gz "fmt", "abc" } ;
- like $@, mkErr("^printf Not Available: File opened only for intput");
-
- #eval { write($gz, $buff, 1) } ;
- #like $@, mkErr("^write Not Available: File opened only for intput");
-
-}
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate')
-{
- $UncompressClass = getInverse($CompressClass);
-
- title "Testing $CompressClass and $UncompressClass";
-
-
- {
- # Write
- # these tests come almost 100% from IO::String
-
- my $lex = new LexFile my $name ;
-
- my $io = $CompressClass->new($name);
-
- is $io->tell(), 0 ;
-
- my $heisan = "Heisan\n";
- print $io $heisan ;
-
- ok ! $io->eof;
-
- is $io->tell(), length($heisan) ;
-
- print($io "a", "b", "c");
-
- {
- local($\) = "\n";
- print $io "d", "e";
- local($,) = ",";
- print $io "f", "g", "h";
- }
-
- my $foo = "1234567890";
-
- ok syswrite($io, $foo, length($foo)) == length($foo) ;
- if ( $[ < 5.6 )
- { is $io->syswrite($foo, length $foo), length $foo }
- else
- { is $io->syswrite($foo), length $foo }
- ok $io->syswrite($foo, length($foo)) == length $foo;
- ok $io->write($foo, length($foo), 5) == 5;
- ok $io->write("xxx\n", 100, -1) == 1;
-
- for (1..3) {
- printf $io "i(%d)", $_;
- $io->printf("[%d]\n", $_);
- }
- select $io;
- print "\n";
- select STDOUT;
-
- close $io ;
-
- ok $io->eof;
-
- is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
- ("1234567890" x 3) . "67890\n" .
- "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
-
-
- }
-
- {
- # Read
- my $str = <<EOT;
-This is an example
-of a paragraph
-
-
-and a single line.
-
-EOT
-
- my $lex = new LexFile my $name ;
-
- my $iow = new $CompressClass $name ;
- print $iow $str ;
- close $iow;
-
- my @tmp;
- my $buf;
- {
- my $io = new $UncompressClass $name ;
-
- ok ! $io->eof;
- is $io->tell(), 0 ;
- my @lines = <$io>;
- is @lines, 6
- or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
- is $lines[1], "of a paragraph\n" ;
- is join('', @lines), $str ;
- is $., 6;
- is $io->tell(), length($str) ;
-
- ok $io->eof;
-
- ok ! ( defined($io->getline) ||
- (@tmp = $io->getlines) ||
- defined(<$io>) ||
- defined($io->getc) ||
- read($io, $buf, 100) != 0) ;
- }
-
-
- {
- local $/; # slurp mode
- my $io = $UncompressClass->new($name);
- ok !$io->eof;
- my @lines = $io->getlines;
- ok $io->eof;
- ok @lines == 1 && $lines[0] eq $str;
-
- $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my $line = <$io>;
- ok $line eq $str;
- ok $io->eof;
- }
-
- {
- local $/ = ""; # paragraph mode
- my $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my @lines = <$io>;
- ok $io->eof;
- ok @lines == 2
- or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
- ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
- or print "# $lines[0]\n";
- ok $lines[1] eq "and a single line.\n\n";
- }
-
- {
- local $/ = "is";
- my $io = $UncompressClass->new($name);
- my @lines = ();
- my $no = 0;
- my $err = 0;
- ok ! $io->eof;
- while (<$io>) {
- push(@lines, $_);
- $err++ if $. != ++$no;
- }
-
- ok $err == 0 ;
- ok $io->eof;
-
- ok @lines == 3
- or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
- ok join("-", @lines) eq
- "This- is- an example\n" .
- "of a paragraph\n\n\n" .
- "and a single line.\n\n";
- }
-
-
- # Test read
-
- {
- my $io = $UncompressClass->new($name);
-
-
- if (! $BadPerl) {
- eval { read($io, $buf, -1) } ;
- like $@, mkErr("length parameter is negative");
- }
-
- is read($io, $buf, 0), 0, "Requested 0 bytes" ;
-
- ok read($io, $buf, 3) == 3 ;
- ok $buf eq "Thi";
-
- ok sysread($io, $buf, 3, 2) == 3 ;
- ok $buf eq "Ths i"
- or print "# [$buf]\n" ;;
- ok ! $io->eof;
-
- # $io->seek(-4, 2);
- #
- # ok ! $io->eof;
- #
- # ok read($io, $buf, 20) == 4 ;
- # ok $buf eq "e.\n\n";
- #
- # ok read($io, $buf, 20) == 0 ;
- # ok $buf eq "";
- #
- # ok ! $io->eof;
- }
-
- }
-
- {
- # Read from non-compressed file
-
- my $str = <<EOT;
-This is an example
-of a paragraph
-
-
-and a single line.
-
-EOT
-
- my $lex = new LexFile my $name ;
-
- writeFile($name, $str);
- my @tmp;
- my $buf;
- {
- my $io = new $UncompressClass $name, -Transparent => 1 ;
-
- ok defined $io;
- ok ! $io->eof;
- ok $io->tell() == 0 ;
- my @lines = <$io>;
- ok @lines == 6;
- ok $lines[1] eq "of a paragraph\n" ;
- ok join('', @lines) eq $str ;
- ok $. == 6;
- ok $io->tell() == length($str) ;
-
- ok $io->eof;
-
- ok ! ( defined($io->getline) ||
- (@tmp = $io->getlines) ||
- defined(<$io>) ||
- defined($io->getc) ||
- read($io, $buf, 100) != 0) ;
- }
-
-
- {
- local $/; # slurp mode
- my $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my @lines = $io->getlines;
- ok $io->eof;
- ok @lines == 1 && $lines[0] eq $str;
-
- $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my $line = <$io>;
- ok $line eq $str;
- ok $io->eof;
- }
-
- {
- local $/ = ""; # paragraph mode
- my $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my @lines = <$io>;
- ok $io->eof;
- ok @lines == 2
- or print "# exected 2 lines, got " . scalar(@lines) . "\n";
- ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
- or print "# [$lines[0]]\n" ;
- ok $lines[1] eq "and a single line.\n\n";
- }
-
- {
- local $/ = "is";
- my $io = $UncompressClass->new($name);
- my @lines = ();
- my $no = 0;
- my $err = 0;
- ok ! $io->eof;
- while (<$io>) {
- push(@lines, $_);
- $err++ if $. != ++$no;
- }
-
- ok $err == 0 ;
- ok $io->eof;
-
- ok @lines == 3 ;
- ok join("-", @lines) eq
- "This- is- an example\n" .
- "of a paragraph\n\n\n" .
- "and a single line.\n\n";
- }
-
-
- # Test read
-
- {
- my $io = $UncompressClass->new($name);
-
- ok read($io, $buf, 3) == 3 ;
- ok $buf eq "Thi";
-
- ok sysread($io, $buf, 3, 2) == 3 ;
- ok $buf eq "Ths i";
- ok ! $io->eof;
-
- # $io->seek(-4, 2);
- #
- # ok ! $io->eof;
- #
- # ok read($io, $buf, 20) == 4 ;
- # ok $buf eq "e.\n\n";
- #
- # ok read($io, $buf, 20) == 0 ;
- # ok $buf eq "";
- #
- # ok ! $io->eof;
- }
-
-
- }
-
- {
- # Vary the length parameter in a read
-
- my $str = <<EOT;
-x
-x
-This is an example
-of a paragraph
-
-
-and a single line.
-
-EOT
- $str = $str x 100 ;
-
-
- foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
- {
- foreach my $trans (0, 1)
- {
- foreach my $append (0, 1)
- {
- title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
-
- my $lex = new LexFile my $name ;
-
- if ($trans) {
- writeFile($name, $str) ;
- }
- else {
- my $iow = new $CompressClass $name ;
- print $iow $str ;
- close $iow;
- }
-
-
- my $io = $UncompressClass->new($name,
- -Append => $append,
- -Transparent => $trans);
-
- my $buf;
-
- is $io->tell(), 0;
-
- if ($append) {
- 1 while $io->read($buf, $bufsize) > 0;
- }
- else {
- my $tmp ;
- $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
- }
- is length $buf, length $str;
- ok $buf eq $str ;
- ok ! $io->error() ;
- ok $io->eof;
- }
- }
- }
- }
-
-}
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "newtied.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "newtied.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "newtied.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "newtied.pl" ;
+run();
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = ("../lib", "lib");
- }
-}
-
-use lib 't';
-use strict;
-use warnings;
-use bytes;
-
-use Test::More ;
-use ZlibTestUtils;
-
-our ($BadPerl);
-
-BEGIN
-{
- plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" )
- if $] < 5.006 ;
-
- my $tests ;
-
- $BadPerl = ($] >= 5.006 or $] <= 5.008) ;
-
- if ($BadPerl) {
- $tests = 242 ;
- }
- else {
- $tests = 242 ;
- }
-
- # use Test::NoWarnings, if available
- my $extra = 0 ;
- $extra = 1
- if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
-
- plan tests => $tests + $extra ;
-
- use_ok('Compress::Zlib', 2) ;
-
- use_ok('IO::Compress::Gzip', qw($GzipError)) ;
- use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
-
- use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
- use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
-
- use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
- use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
-
-
-}
-
-
-use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
-
-
-our ($UncompressClass);
-
-
-sub myGZreadFile
-{
- my $filename = shift ;
- my $init = shift ;
-
-
- my $fil = new $UncompressClass $filename,
- -Strict => 1,
- -Append => 1
- ;
-
- my $data ;
- $data = $init if defined $init ;
- 1 while $fil->read($data) > 0;
-
- $fil->close ;
- return $data ;
-}
-
-# Check zlib_version and ZLIB_VERSION are the same.
-is Compress::Zlib::zlib_version, ZLIB_VERSION,
- "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
-
-
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate',
- )
-{
- $UncompressClass = getInverse($CompressClass);
-
- title "Testing $CompressClass and $UncompressClass";
-
-
-
- {
- # Write
- # these tests come almost 100% from IO::String
-
- my $lex = new LexFile my $name ;
-
- my $io = $CompressClass->new($name);
-
- is tell($io), 0 ;
- is $io->tell(), 0 ;
-
- my $heisan = "Heisan\n";
- print $io $heisan ;
-
- ok ! eof($io);
- ok ! $io->eof();
-
- is tell($io), length($heisan) ;
- is $io->tell(), length($heisan) ;
-
- $io->print("a", "b", "c");
-
- {
- local($\) = "\n";
- print $io "d", "e";
- local($,) = ",";
- print $io "f", "g", "h";
- }
-
- my $foo = "1234567890";
-
- ok syswrite($io, $foo, length($foo)) == length($foo) ;
- if ( $[ < 5.6 )
- { is $io->syswrite($foo, length $foo), length $foo }
- else
- { is $io->syswrite($foo), length $foo }
- ok $io->syswrite($foo, length($foo)) == length $foo;
- ok $io->write($foo, length($foo), 5) == 5;
- ok $io->write("xxx\n", 100, -1) == 1;
-
- for (1..3) {
- printf $io "i(%d)", $_;
- $io->printf("[%d]\n", $_);
- }
- select $io;
- print "\n";
- select STDOUT;
-
- close $io ;
-
- ok eof($io);
- ok $io->eof();
-
- is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
- ("1234567890" x 3) . "67890\n" .
- "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
-
-
- }
-
- {
- # Read
- my $str = <<EOT;
-This is an example
-of a paragraph
-
-
-and a single line.
-
-EOT
-
- my $lex = new LexFile my $name ;
-
- my $iow = new $CompressClass $name ;
- print $iow $str ;
- close $iow;
-
- my @tmp;
- my $buf;
- {
- my $io = new $UncompressClass $name ;
-
- ok ! $io->eof;
- ok ! eof $io;
- is $io->tell(), 0 ;
- is tell($io), 0 ;
- my @lines = <$io>;
- is @lines, 6
- or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
- is $lines[1], "of a paragraph\n" ;
- is join('', @lines), $str ;
- is $., 6;
- #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ;
- is $io->tell(), length($str) ;
- is tell($io), length($str) ;
-
- ok $io->eof;
- ok eof $io;
-
- ok ! ( defined($io->getline) ||
- (@tmp = $io->getlines) ||
- defined(<$io>) ||
- defined($io->getc) ||
- read($io, $buf, 100) != 0) ;
- }
-
-
- {
- local $/; # slurp mode
- my $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my @lines = $io->getlines;
- ok $io->eof;
- ok @lines == 1 && $lines[0] eq $str;
-
- $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my $line = <$io>;
- ok $line eq $str;
- ok $io->eof;
- }
-
- {
- local $/ = ""; # paragraph mode
- my $io = $UncompressClass->new($name);
- ok ! $io->eof;
- my @lines = <$io>;
- ok $io->eof;
- ok @lines == 2
- or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
- ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
- or print "# $lines[0]\n";
- ok $lines[1] eq "and a single line.\n\n";
- }
-
- {
- local $/ = "is";
- my $io = $UncompressClass->new($name);
- my @lines = ();
- my $no = 0;
- my $err = 0;
- ok ! $io->eof;
- while (<$io>) {
- push(@lines, $_);
- $err++ if $. != ++$no;
- }
-
- ok $err == 0 ;
- ok $io->eof;
-
- ok @lines == 3
- or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
- ok join("-", @lines) eq
- "This- is- an example\n" .
- "of a paragraph\n\n\n" .
- "and a single line.\n\n";
- }
-
-
- # Test read
-
- {
- my $io = $UncompressClass->new($name);
-
- ok $io, "opened ok" ;
-
- #eval { read($io, $buf, -1); } ;
- #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ;
-
- #eval { read($io, 1) } ;
- #like $@, mkErr("buffer parameter is read-only");
-
- is read($io, $buf, 0), 0, "Requested 0 bytes" ;
-
- ok read($io, $buf, 3) == 3 ;
- ok $buf eq "Thi";
-
- ok sysread($io, $buf, 3, 2) == 3 ;
- ok $buf eq "Ths i"
- or print "# [$buf]\n" ;;
- ok ! $io->eof;
-
- # $io->seek(-4, 2);
- #
- # ok ! $io->eof;
- #
- # ok read($io, $buf, 20) == 4 ;
- # ok $buf eq "e.\n\n";
- #
- # ok read($io, $buf, 20) == 0 ;
- # ok $buf eq "";
- #
- # ok ! $io->eof;
- }
-
- }
-
-
-
- {
- title "seek tests" ;
-
- my $lex = new LexFile my $name ;
-
- my $first = "beginning" ;
- my $last = "the end" ;
- my $iow = new $CompressClass $name ;
- print $iow $first ;
- ok seek $iow, 10, SEEK_CUR ;
- is tell($iow), length($first)+10;
- ok $iow->seek(0, SEEK_CUR) ;
- is tell($iow), length($first)+10;
- print $iow $last ;
- close $iow;
-
- my $io = $UncompressClass->new($name);
- ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ;
-
- $io = $UncompressClass->new($name);
- ok seek $io, length($first)+10, SEEK_CUR ;
- ok ! $io->eof;
- is tell($io), length($first)+10;
- ok seek $io, 0, SEEK_CUR ;
- is tell($io), length($first)+10;
- my $buff ;
- ok read $io, $buff, 100 ;
- ok $buff eq $last ;
- ok $io->eof;
- }
-
- if (! $BadPerl)
- {
- # seek error cases
- my $b ;
- my $a = new $CompressClass(\$b) ;
-
- ok ! $a->error() ;
- eval { seek($a, -1, 10) ; };
- like $@, mkErr("^seek: unknown value, 10, for whence parameter");
-
- eval { seek($a, -1, SEEK_END) ; };
- like $@, mkErr("^cannot seek backwards");
-
- print $a "fred";
- close $a ;
-
-
- my $u = new $UncompressClass(\$b) ;
-
- eval { seek($u, -1, 10) ; };
- like $@, mkErr("^seek: unknown value, 10, for whence parameter");
-
- eval { seek($u, -1, SEEK_END) ; };
- like $@, mkErr("^seek: SEEK_END not allowed");
-
- eval { seek($u, -1, SEEK_CUR) ; };
- like $@, mkErr("^cannot seek backwards");
- }
-
- {
- title 'fileno' ;
-
- my $lex = new LexFile my $name ;
-
- my $hello = <<EOM ;
-hello world
-this is a test
-EOM
-
- {
- my $fh ;
- ok $fh = new IO::File ">$name" ;
- my $x ;
- ok $x = new $CompressClass $fh ;
-
- ok $x->fileno() == fileno($fh) ;
- ok $x->fileno() == fileno($x) ;
- ok $x->write($hello) ;
- ok $x->close ;
- $fh->close() ;
- }
-
- my $uncomp;
- {
- my $x ;
- ok my $fh1 = new IO::File "<$name" ;
- ok $x = new $UncompressClass $fh1, -Append => 1 ;
- ok $x->fileno() == fileno $fh1 ;
- ok $x->fileno() == fileno $x ;
-
- 1 while $x->read($uncomp) > 0 ;
-
- ok $x->close ;
- }
-
- ok $hello eq $uncomp ;
- }
-}
-
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "merge.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "merge.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "merge.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use Test::More skip_all => "not implemented yet";
+
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "merge.pl" ;
+run();
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = ("../lib", "lib");
- }
-}
-
-use lib 't';
-use strict;
-use warnings;
-use bytes;
-
-use Test::More ;
-use ZlibTestUtils;
-
-our ($extra);
-use Compress::Zlib 2 ;
-
-use IO::Compress::Gzip qw($GzipError);
-use IO::Uncompress::Gunzip qw($GunzipError);
-
-use IO::Compress::Deflate qw($DeflateError);
-use IO::Uncompress::Inflate qw($InflateError);
-
-use IO::Compress::RawDeflate qw($RawDeflateError);
-use IO::Uncompress::RawInflate qw($RawInflateError);
-
-
-BEGIN
-{
- plan(skip_all => "Merge needs Zlib 1.2.1 or better - you have Zlib "
- . Compress::Zlib::zlib_version())
- if ZLIB_VERNUM() < 0x1210 ;
-
- # use Test::NoWarnings, if available
- $extra = 0 ;
- $extra = 1
- if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
-
- plan tests => 490 + $extra ;
-
-}
-
-
-# Check zlib_version and ZLIB_VERSION are the same.
-is Compress::Zlib::zlib_version, ZLIB_VERSION,
- "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
-
-# Tests
-# destination is a file that doesn't exist -- should work ok unless AnyDeflate
-# destination isn't compressed at all
-# destination is compressed but wrong format
-# destination is corrupt - error messages should be correct
-# use apend mode with old zlib - check that this is trapped
-# destination is not seekable, readable, writable - test for filename & handle
-
-{
- title "Misc error cases";
-
- eval { new Compress::Zlib::InflateScan Bufsize => 0} ;
- like $@, mkErr("^Compress::Zlib::InflateScan::new: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0";
-
- eval { Compress::Zlib::inflateScanStream::createDeflateStream(undef, Bufsize => 0) } ;
- like $@, mkErr("^Compress::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0";
-
-}
-
-# output file/handle not writable
-foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) )
-{
-
- my $Error = getErrorRef($CompressClass);
-
- foreach my $to_file (0,1)
- {
- if ($to_file)
- { title "$CompressClass - Merge to filename that isn't writable" }
- else
- { title "$CompressClass - Merge to filehandle that isn't writable" }
-
- my $lex = new LexFile my $out_file ;
-
- # create empty file
- open F, ">$out_file" ; print F "x"; close F;
- ok -e $out_file, " file exists" ;
- ok !-z $out_file, " and is not empty" ;
-
- # make unwritable
- is chmod(0444, $out_file), 1, " chmod worked" ;
- ok -e $out_file, " still exists after chmod" ;
-
- SKIP:
- {
- skip "Cannot create non-writable file", 3
- if -w $out_file ;
-
- ok ! -w $out_file, " chmod made file unwritable" ;
-
- my $dest ;
- if ($to_file)
- { $dest = $out_file }
- else
- { $dest = new IO::File "<$out_file" }
-
- my $gz = $CompressClass->new($dest, Merge => 1) ;
-
- ok ! $gz, " Did not create $CompressClass object";
-
- {
- if ($to_file) {
- is $$Error, "Output file '$out_file' is not writable",
- " Got non-writable filename message" ;
- }
- else {
- is $$Error, "Output filehandle is not writable",
- " Got non-writable filehandle message" ;
- }
- }
- }
-
- chmod 0777, $out_file ;
- }
-}
-
-# output is not compressed at all
-foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) )
-{
-
- my $Error = getErrorRef($CompressClass);
-
- my $lex = new LexFile my $out_file ;
-
- foreach my $to_file ( qw(buffer file handle ) )
- {
- title "$CompressClass to $to_file, content is not compressed";
-
- my $content = "abc" x 300 ;
- my $buffer ;
- my $disp_content = defined $content ? $content : '<undef>' ;
- my $str_content = defined $content ? $content : '' ;
-
- if ($to_file eq 'buffer')
- {
- $buffer = \$content ;
- }
- else
- {
- writeFile($out_file, $content);
-
- if ($to_file eq 'handle')
- {
- $buffer = new IO::File "+<$out_file"
- or die "# Cannot open $out_file: $!";
- }
- else
- { $buffer = $out_file }
- }
-
- ok ! $CompressClass->new($buffer, Merge => 1), " constructor fails";
- {
- like $$Error, '/Cannot create InflateScan object: (Header Error|unexpected end of file)/', " got Bad Magic" ;
- }
-
- }
-}
-
-# output is empty
-foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) )
-{
-
- my $Error = getErrorRef($CompressClass);
-
- my $lex = new LexFile my $out_file ;
-
- foreach my $to_file ( qw(buffer file handle ) )
- {
- title "$CompressClass to $to_file, content is empty";
-
- my $content = '';
- my $buffer ;
- my $dest ;
-
- if ($to_file eq 'buffer')
- {
- $dest = $buffer = \$content ;
- }
- else
- {
- writeFile($out_file, $content);
- $dest = $out_file;
-
- if ($to_file eq 'handle')
- {
- $buffer = new IO::File "+<$out_file"
- or die "# Cannot open $out_file: $!";
- }
- else
- { $buffer = $out_file }
- }
-
- ok my $gz = $CompressClass->new($buffer, Merge => 1, AutoClose => 1), " constructor passes";
-
- $gz->write("FGHI");
- $gz->close();
-
- #hexDump($buffer);
- my $out = anyUncompress($dest);
-
- is $out, "FGHI", ' Merge OK';
- }
-}
-
-foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) )
-{
- my $Error = getErrorRef($CompressClass);
-
- title "$CompressClass - Merge to file that doesn't exist";
-
- my $lex = new LexFile my $out_file ;
-
- ok ! -e $out_file, " Destination file, '$out_file', does not exist";
-
- ok my $gz1 = $CompressClass->new($out_file, Merge => 1)
- or die "# $CompressClass->new failed: $GzipError\n";
- #hexDump($buffer);
- $gz1->write("FGHI");
- $gz1->close();
-
- #hexDump($buffer);
- my $out = anyUncompress($out_file);
-
- is $out, "FGHI", ' Merged OK';
-}
-
-foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) )
-{
- my $Error = getErrorRef($CompressClass);
-
- my $lex = new LexFile my $out_file ;
-
- foreach my $to_file ( qw( buffer file handle ) )
- {
- foreach my $content (undef, '', 'x', 'abcde')
- {
- #next if ! defined $content && $to_file;
-
- my $buffer ;
- my $disp_content = defined $content ? $content : '<undef>' ;
- my $str_content = defined $content ? $content : '' ;
-
- if ($to_file eq 'buffer')
- {
- my $x ;
- $buffer = \$x ;
- title "$CompressClass to Buffer, content is '$disp_content'";
- }
- else
- {
- $buffer = $out_file ;
- if ($to_file eq 'handle')
- {
- title "$CompressClass to Filehandle, content is '$disp_content'";
- }
- else
- {
- title "$CompressClass to File, content is '$disp_content'";
- }
- }
-
- my $gz = $CompressClass->new($buffer);
- my $len = defined $content ? length($content) : 0 ;
- is $gz->write($content), $len, " write ok";
- ok $gz->close(), " close ok";
-
- #hexDump($buffer);
- is anyUncompress($buffer), $str_content, ' Destination is ok';
-
- #if ($corruption)
- #{
- # next if $TopTypes eq 'RawDeflate' && $content eq '';
- #
- #}
-
- my $dest = $buffer ;
- if ($to_file eq 'handle')
- {
- $dest = new IO::File "+<$buffer" ;
- }
-
- my $gz1 = $CompressClass->new($dest, Merge => 1, AutoClose => 1)
- or die "## Error is $$Error\n";
-
- #print "YYY\n";
- #hexDump($buffer);
- #print "XXX\n";
- is $gz1->write("FGHI"), 4, " write returned 4";
- ok $gz1->close(), " close ok";
-
- #hexDump($buffer);
- my $out = anyUncompress($buffer);
-
- is $out, $str_content . "FGHI", ' Merged OK';
- #exit;
- }
- }
-
-}
-
-
-
-foreach my $CompressClass ( map { "IO::Compress::$_" } qw( Gzip RawDeflate Deflate) )
-{
- my $Error = getErrorRef($CompressClass);
-
- my $Func = getTopFuncRef($CompressClass);
- my $TopType = getTopFuncName($CompressClass);
-
- my $buffer ;
-
- my $lex = new LexFile my $out_file ;
-
- foreach my $to_file (0, 1)
- {
- foreach my $content (undef, '', 'x', 'abcde')
- {
- my $disp_content = defined $content ? $content : '<undef>' ;
- my $str_content = defined $content ? $content : '' ;
- my $buffer ;
- if ($to_file)
- {
- $buffer = $out_file ;
- title "$TopType to File, content is '$disp_content'";
- }
- else
- {
- my $x = '';
- $buffer = \$x ;
- title "$TopType to Buffer, content is '$disp_content'";
- }
-
-
- ok $Func->(\$content, $buffer), " Compress content";
- #hexDump($buffer);
- is anyUncompress($buffer), $str_content, ' Destination is ok';
-
-
- ok $Func->(\"FGHI", $buffer, Merge => 1), " Merge content";
-
- #hexDump($buffer);
- my $out = anyUncompress($buffer);
-
- is $out, $str_content . "FGHI", ' Merged OK';
- }
- }
-
-}
-
-
-
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
$extra = 1
if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
- plan tests => 29 + $extra ;
+ plan tests => 30 + $extra ;
use_ok('Compress::Zlib::Common');
use_ok('Compress::Zlib::ParseParameters');
-# use_ok('Compress::Zlib', 2) ;
-#
-# use_ok('IO::Compress::Gzip', qw($GzipError)) ;
-# use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
-#
-# use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
-# use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
-#
-# use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
-# use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
}
like $@, mkErr(': Expected even number of parameters, got 1'),
"Trap odd number of params";
- eval { ParseParameters(1, {'Fred' => [Parse_unsigned, 0]}, Fred => undef) ; };
- like $@, mkErr("Parameter 'Fred' must be an unsigned int, got undef"),
+ eval { ParseParameters(1, {'Fred' => [1, 1, Parse_boolean, 0]}, Fred => 'joe') ; };
+ like $@, mkErr("Parameter 'Fred' must be an int, got 'joe'"),
"wanted unsigned, got undef";
- eval { ParseParameters(1, {'Fred' => [Parse_signed, 0]}, Fred => undef) ; };
- like $@, mkErr("Parameter 'Fred' must be a signed int, got undef"),
+ eval { ParseParameters(1, {'Fred' => [1, 1, Parse_unsigned, 0]}, Fred => undef) ; };
+ like $@, mkErr("Parameter 'Fred' must be an unsigned int, got 'undef'"),
+ "wanted unsigned, got undef";
+
+ eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => undef) ; };
+ like $@, mkErr("Parameter 'Fred' must be a signed int, got 'undef'"),
"wanted signed, got undef";
- eval { ParseParameters(1, {'Fred' => [Parse_signed, 0]}, Fred => 'abc') ; };
+ eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => 'abc') ; };
like $@, mkErr("Parameter 'Fred' must be a signed int, got 'abc'"),
"wanted signed, got 'abc'";
- my $got = ParseParameters(1, {'Fred' => [Parse_store_ref, 0]}, Fred => 'abc') ;
+ my $got = ParseParameters(1, {'Fred' => [1, 1, Parse_store_ref, 0]}, Fred => 'abc') ;
is ${ $got->value('Fred') }, "abc", "Parse_store_ref" ;
- $got = ParseParameters(1, {'Fred' => [0x1000000, 0]}, Fred => 'abc') ;
+ $got = ParseParameters(1, {'Fred' => [1, 1, 0x1000000, 0]}, Fred => 'abc') ;
is $got->value('Fred'), "abc", "other" ;
}
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Uncompress::AnyUncompress qw($AnyUncompressError) ;
+
+use IO::Compress::Deflate qw($DeflateError) ;
+use IO::Uncompress::Inflate qw($InflateError) ;
+
+sub getClass
+{
+ 'AnyUncompress';
+}
+
+
+sub identify
+{
+ 'IO::Compress::Deflate';
+}
+
+require "any.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Uncompress::AnyUncompress qw($AnyUncompressError) ;
+
+use IO::Compress::Gzip qw($GzipError) ;
+use IO::Uncompress::Gunzip qw($GunzipError) ;
+
+sub getClass
+{
+ 'AnyUncompress';
+}
+
+
+sub identify
+{
+ 'IO::Compress::Gzip';
+}
+
+require "any.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Uncompress::AnyUncompress qw($AnyUncompressError) ;
+
+use IO::Compress::RawDeflate qw($RawDeflateError) ;
+use IO::Uncompress::RawInflate qw($RawInflateError) ;
+
+sub getClass
+{
+ 'AnyUncompress';
+}
+
+
+sub identify
+{
+ 'IO::Compress::RawDeflate';
+}
+
+require "any.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+BEGIN {
+ # use Test::NoWarnings, if available
+ my $extra = 0 ;
+ $extra = 1
+ if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
+
+ plan tests => 15 + $extra ;
+
+ use_ok('IO::Uncompress::AnyUncompress', qw($AnyUncompressError)) ;
+
+}
+
+{
+
+ my $string = <<EOM;
+This is not compressed data
+EOM
+
+ my $buffer = $string ;
+
+ for my $file (0, 1)
+ {
+ title "AnyUncompress with Non-compressed data (File $file)" ;
+
+ my $lex = new LexFile my $output;
+ my $input ;
+
+ if ($file) {
+ writeFile($output, $buffer);
+ $input = $output;
+ }
+ else {
+ $input = \$buffer;
+ }
+
+
+ my $unc ;
+ my $keep = $buffer ;
+ $unc = new IO::Uncompress::AnyUncompress $input, -Transparent => 0 ;
+ ok ! $unc," no AnyUncompress object when -Transparent => 0" ;
+ is $buffer, $keep ;
+
+ $buffer = $keep ;
+ $unc = new IO::Uncompress::AnyUncompress \$buffer, -Transparent => 1 ;
+ ok $unc, " AnyUncompress object when -Transparent => 1" ;
+
+ my $uncomp ;
+ ok $unc->read($uncomp) > 0 ;
+ ok $unc->eof() ;
+ #ok $unc->type eq $Type;
+
+ is $uncomp, $string ;
+ }
+}
+
+1;
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use strict;
+use warnings;
+
+use IO::Uncompress::AnyUncompress qw($AnyUncompressError) ;
+
+use IO::Compress::Zip qw($ZipError) ;
+use IO::Uncompress::Unzip qw($UnzipError) ;
+
+sub getClass
+{
+ 'AnyUncompress';
+}
+
+
+sub identify
+{
+ 'IO::Compress::Zip';
+}
+
+require "any.pl" ;
+run();
--- /dev/null
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = ("../lib", "lib/compress");
+ }
+}
+
+use lib 't';
+use Test::More;
+
+eval "use Test::Pod 1.00";
+
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+
+all_pod_files_ok();
+
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
- @INC = ("../lib", "lib");
+ @INC = ("../lib", "lib/compress");
}
}
+++ /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, @_;
- for (@_) { 1 while unlink $_ } ;
- bless [ @_ ], $self ;
- }
-
- sub DESTROY
- {
- my $self = shift ;
- chmod 0777, @{ $self } ;
- for (@$self) { 1 while unlink $_ } ;
- }
-
-}
-
-{
- 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;
--- /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, @_;
+ for (@_) { 1 while unlink $_ } ;
+ bless [ @_ ], $self ;
+ }
+
+ sub DESTROY
+ {
+ my $self = shift ;
+ chmod 0777, @{ $self } ;
+ for (@$self) { 1 while unlink $_ } ;
+ }
+
+}
+
+{
+ 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 croak "Cannot open $f: $!\n" ;
+ @strings = <F> ;
+ close F ;
+ }
+
+ return @strings if wantarray ;
+ return join "", @strings ;
+}
+
+sub touch
+{
+ foreach (@_) { writeFile($_, '') }
+}
+
+sub writeFile
+{
+ my($filename, @strings) = @_ ;
+ 1 while unlink $filename ;
+ open (F, ">$filename")
+ or croak "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 croak "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 ;
+
+ is GZreadFile($name), $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',
+ 'IO::Compress::Bzip2' => 'IO::Uncompress::Bunzip2',
+ 'IO::Compress::Bzip2::bzip2' => 'IO::Uncompress::Bunzip2',
+ 'IO::Compress::Zip' => 'IO::Uncompress::Unzip',
+ 'IO::Compress::Zip::zip' => 'IO::Uncompress::Unzip',
+ 'IO::Compress::Lzop' => 'IO::Uncompress::UnLzop',
+ 'IO::Compress::Lzop::lzop' => 'IO::Uncompress::UnLzop',
+ );
+
+ my $out ;
+ 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::Uncompress::AnyUncompress' => \$IO::Uncompress::AnyUncompress::AnyUncompressError,
+ 'IO::Uncompress::AnyUncompress::anyUncompress' => \$IO::Uncompress::AnyUncompress::AnyUncompressError,
+ 'IO::Compress::RawDeflate' => \$IO::Compress::RawDeflate::RawDeflateError,
+ 'IO::Compress::RawDeflate::rawdeflate' => \$IO::Compress::RawDeflate::RawDeflateError,
+ 'IO::Compress::Bzip2' => \$IO::Compress::Bzip2::Bzip2Error,
+ 'IO::Compress::Bzip2::bzip2' => \$IO::Compress::Bzip2::Bzip2Error,
+ 'IO::Uncompress::Bunzip2' => \$IO::Uncompress::Bunzip2::Bunzip2Error,
+ 'IO::Uncompress::Bunzip2::bunzip2' => \$IO::Uncompress::Bunzip2::Bunzip2Error,
+ 'IO::Compress::Zip' => \$IO::Compress::Zip::ZipError,
+ 'IO::Compress::Zip::zip' => \$IO::Compress::Zip::ZipError,
+ 'IO::Uncompress::Unzip' => \$IO::Uncompress::Unzip::UnzipError,
+ 'IO::Uncompress::Unzip::unzip' => \$IO::Uncompress::Unzip::UnzipError,
+ 'IO::Compress::Lzop' => \$IO::Compress::Lzop::LzopError,
+ 'IO::Compress::Lzop::lzop' => \$IO::Compress::Lzop::LzopError,
+ 'IO::Uncompress::UnLzop' => \$IO::Uncompress::UnLzop::UnLzopError,
+ 'IO::Uncompress::UnLzop::unlzop' => \$IO::Uncompress::UnLzop::UnLzopError,
+ );
+
+my %TopFuncMap = ( 'IO::Compress::Gzip' => 'IO::Compress::Gzip::gzip',
+ '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',
+ 'IO::Uncompress::AnyUncompress' => 'IO::Uncompress::AnyUncompress::anyuncompress',
+
+ 'IO::Compress::Bzip2' => 'IO::Compress::Bzip2::bzip2',
+ 'IO::Uncompress::Bunzip2' => 'IO::Uncompress::Bunzip2::bunzip2',
+
+ 'IO::Compress::Zip' => 'IO::Compress::Zip::zip',
+ 'IO::Uncompress::Unzip' => 'IO::Uncompress::Unzip::unzip',
+ 'IO::Compress::Lzop' => 'IO::Compress::Lzop::lzop',
+ 'IO::Uncompress::UnLzop' => 'IO::Uncompress::UnLzop::unlzop',
+ );
+
+ %TopFuncMap = map { ($_ => $TopFuncMap{$_},
+ $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',
+ 'IO::Compress::Bzip2::bzip2' => 'IO::Uncompress::Bunzip2::bunzip2',
+ 'IO::Compress::Bzip2' => 'IO::Uncompress::Bunzip2',
+ 'IO::Compress::Zip::zip' => 'IO::Uncompress::Unzip::unzip',
+ 'IO::Compress::Zip' => 'IO::Uncompress::Unzip',
+ 'IO::Compress::Lzop::lzop' => 'IO::Uncompress::UnLzop::unlzop',
+ 'IO::Compress::Lzop' => 'IO::Uncompress::UnLzop',
+ );
+
+%inverse = map { ($_ => $inverse{$_}, $inverse{$_} => $_) } keys %inverse;
+
+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::Bunzip2' => 'IO::Compress::Bzip2',
+ 'IO::Uncompress::Bunzip2::bunzip2' => 'IO::Compress::Bzip2',
+ 'IO::Uncompress::Unzip' => 'IO::Compress::Zip',
+ 'IO::Uncompress::Unzip::unzip' => 'IO::Compress::Zip',
+ 'IO::Uncompress::UnLzop' => 'IO::Compress::Lzop',
+ 'IO::Uncompress::UnLzop::unlzop' => 'IO::Compress::Lzop',
+ 'IO::Uncompress::AnyInflate' => 'IO::Compress::Gzip',
+ 'IO::Uncompress::AnyInflate::anyinflate' => 'IO::Compress::Gzip',
+ 'IO::Uncompress::AnyUncompress' => 'IO::Compress::Gzip',
+ 'IO::Uncompress::AnyUncompress::anyuncompress' => 'IO::Compress::Gzip',
+ );
+
+ my $out ;
+ my $obj = $mapping{$compWith}->new( \$out);
+ $obj->write($buffer) ;
+ $obj->close();
+ return $out ;
+
+}
+
+use IO::Uncompress::AnyUncompress qw($AnyUncompressError);
+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::AnyUncompress \$data, -Append => 1, Transparent => 0, @opts
+ or croak "Cannot open buffer/file: $AnyUncompressError" ;
+
+ 1 while $o->read($out) > 0 ;
+
+ croak "Error uncompressing -- " . $o->error()
+ if $o->error() ;
+
+ return $out ;
+
+}
+
+sub getHeaders
+{
+ my $buffer = shift ;
+ my $already = shift;
+
+ my @opts = ();
+ if (ref $buffer && ref $buffer eq 'ARRAY')
+ {
+ @opts = @$buffer;
+ $buffer = shift @opts;
+ }
+
+ if (ref $buffer)
+ {
+ croak "buffer is undef" unless defined $$buffer;
+ croak "buffer is empty" unless length $$buffer;
+
+ }
+
+
+ my $data ;
+ if (Compress::Zlib::Common::isaFilehandle($buffer))
+ {
+ $data = readFile($buffer);
+ }
+ elsif (Compress::Zlib::Common::isaFilename($buffer))
+ {
+ $data = readFile($buffer);
+ }
+ else
+ {
+ $data = $$buffer ;
+ }
+
+ if (defined $already && length $already)
+ {
+
+ my $got = substr($data, 0, length($already));
+ substr($data, 0, length($already)) = '';
+
+ is $got, $already, ' Already OK' ;
+ }
+
+ my $out = '';
+ my $o = new IO::Uncompress::AnyUncompress \$data, MultiStream => 1, -Append => 1, Transparent => 0, @opts
+ or croak "Cannot open buffer/file: $AnyUncompressError" ;
+
+ 1 while $o->read($out) > 0 ;
+
+ croak "Error uncompressing -- " . $o->error()
+ if $o->error() ;
+
+ return ($o->getHeaderInfo()) ;
+
+}
+
+sub mkComplete
+{
+ my $class = shift ;
+ my $data = shift;
+ my $Error = getErrorRef($class);
+
+ my $buffer ;
+ my %params = ();
+
+ if ($class eq 'IO::Compress::Gzip') {
+ %params = (
+ -Name => "My name",
+ -Comment => "a comment",
+ -ExtraField => ['ab' => "extra"],
+ -HeaderCRC => 1);
+ }
+ elsif ($class eq 'IO::Compress::Zip'){
+ %params = (
+ # TODO -- add more here
+ -Name => "My name",
+ -Comment => "a comment",
+ );
+ }
+
+ my $z = new $class( \$buffer, %params)
+ or croak "Cannot create $class object: $$Error";
+ $z->write($data);
+ $z->close();
+
+ my $unc = getInverse($class);
+ my $u = new $unc( \$buffer);
+ my $info = $u->getHeaderInfo() ;
+
+
+ return wantarray ? ($info, $buffer) : $buffer ;
+}
+
+sub mkErr
+{
+ my $string = shift ;
+ my ($dummy, $file, $line) = caller ;
+ -- $line ;
+
+ $file = quotemeta($file);
+
+ return "/$string\\s+at $file line $line/" if $] >= 5.006 ;
+ return "/$string\\s+at /" ;
+}
+
+sub mkEvalErr
+{
+ my $string = shift ;
+
+ return "/$string\\s+at \\(eval /" if $] > 5.006 ;
+ return "/$string\\s+at /" ;
+}
+
+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;
--- /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 => 36 + $extra ;
+
+}
+
+sub run
+{
+ my $CompressClass = identify();
+ my $AnyClass = getClass();
+ my $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+ my $AnyConstruct = "IO::Uncompress::${AnyClass}" ;
+ no strict 'refs';
+ my $AnyError = \${ "IO::Uncompress::${AnyClass}::${AnyClass}Error" };
+
+ for my $trans ( 0, 1 )
+ {
+ for my $file ( 0, 1 )
+ {
+ title "$AnyClass(Transparent => $trans, File=>$file) with $CompressClass" ;
+ my $string = "some text";
+
+ my $buffer ;
+ my $x = new $CompressClass(\$buffer) ;
+ ok $x, " create $CompressClass object" ;
+ ok $x->write($string), " write to object" ;
+ ok $x->close, " close ok" ;
+
+ my $lex = new LexFile my $output;
+ my $input ;
+
+ if ($file) {
+ writeFile($output, $buffer);
+ $input = $output;
+ }
+ else {
+ $input = \$buffer;
+ }
+
+ my $unc = new $AnyConstruct $input, Transparent => $trans ;
+
+ ok $unc, " Created $AnyClass object"
+ or print "# $$AnyError\n";
+ my $uncomp ;
+ ok $unc->read($uncomp) > 0
+ or print "# $$AnyError\n";
+ my $y;
+ is $unc->read($y, 1), 0, " at eof" ;
+ ok $unc->eof(), " at eof" ;
+ #ok $unc->type eq $Type;
+
+ is $uncomp, $string, " expected output" ;
+ }
+ }
+}
+
+1;
--- /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 => 36 + $extra ;
+}
+
+sub run
+{
+ my $CompressClass = identify();
+ my $AnyClass = getClass();
+ my $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+ my $AnyConstruct = "IO::Uncompress::${AnyClass}" ;
+ no strict refs;
+ my $AnyError = \${ "IO::Uncompress::${AnyClass}::${AnyClass}Error" };
+
+ for my $trans ( 0, 1 )
+ {
+ for my $file ( 0, 1 )
+ {
+ title "$AnyClass(Transparent => $trans, File=>$file) with $CompressClass" ;
+ my $string = "some text";
+
+ my $buffer ;
+ my $x = new $CompressClass(\$buffer) ;
+ ok $x, " create $CompressClass object" ;
+ ok $x->write($string), " write to object" ;
+ ok $x->close, " close ok" ;
+
+ my $lex = new LexFile my $output;
+ my $input ;
+
+ if ($file) {
+ writeFile($output, $buffer);
+ $input = $output;
+ }
+ else {
+ $input = \$buffer;
+ }
+
+ my $unc = new $AnyConstruct $input, Transparent => $trans ;
+
+ ok $unc, " Created $AnyClass object"
+ or print "# $$AnyError\n";
+ my $uncomp ;
+ ok $unc->read($uncomp) > 0
+ or print "# $$AnyError\n";
+ my $y;
+ is $unc->read($y, 1), 0, " at eof" ;
+ ok $unc->eof(), " at eof" ;
+ #ok $unc->type eq $Type;
+
+ is $uncomp, $string, " expected output" ;
+ }
+ }
+}
+
+1;
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = ("../lib", "lib");
- }
-}
use lib 't';
use strict;
$extra = 1
if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
- plan tests => 23 + $extra ;
+ plan tests => 7 + $extra ;
- use_ok('IO::Compress::Gzip', qw($GzipError)) ;
- use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
- use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ;
- use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
use_ok('IO::File') ;
}
-
-foreach my $CompressClass ('IO::Compress::Gzip',
- 'IO::Compress::Deflate',
- 'IO::Compress::RawDeflate')
+sub run
{
- title "Testing $CompressClass";
+ my $CompressClass = identify();
+ my $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+ title "Testing $CompressClass";
{
# Check that the class destructor will call close
}
}
+1;
--- /dev/null
+
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+
+our ($UncompressClass);
+BEGIN
+{
+ # use Test::NoWarnings, if available
+ my $extra = 0 ;
+
+ my $st = eval { require Test::NoWarnings ; import Test::NoWarnings; 1; };
+ $extra = 1
+ if $st ;
+
+
+
+ plan(tests => 564 + $extra) ;
+}
+
+
+
+
+sub myGZreadFile
+{
+ my $filename = shift ;
+ my $init = shift ;
+
+
+ my $fil = new $UncompressClass $filename,
+ -Strict => 0,
+ -Append => 1
+ ;
+
+ my $data = '';
+ $data = $init if defined $init ;
+ 1 while $fil->read($data) > 0;
+
+ $fil->close ;
+ return $data ;
+}
+
+sub run
+{
+
+ my $CompressClass = identify();
+ $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+ {
+
+ title "Testing $CompressClass Errors";
+
+ # Buffer not writable
+ eval qq[\$a = new $CompressClass(\\1) ;] ;
+ like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ;
+
+ my($out, $gz);
+ $out = "" ;
+ eval qq[\$a = new $CompressClass ] . '$out ;' ;
+ like $@, mkEvalErr("^$CompressClass: output filename is undef or null string");
+
+ $out = undef ;
+ eval qq[\$a = new $CompressClass \$out ;] ;
+ like $@, mkEvalErr("^$CompressClass: output filename is undef or null string");
+
+ my $x ;
+ $gz = new $CompressClass(\$x);
+
+ foreach my $name (qw(read readline getc))
+ {
+ eval " \$gz->$name() " ;
+ like $@, mkEvalErr("^$name Not Available: File opened only for output");
+ }
+
+ eval ' $gz->write({})' ;
+ like $@, mkEvalErr("^${CompressClass}::write: not a scalar reference");
+ #like $@, mkEvalErr("^${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref");
+
+ eval ' $gz->syswrite("abc", 1, 5)' ;
+ like $@, mkEvalErr("^${CompressClass}::write: offset outside string");
+
+ eval ' $gz->syswrite("abc", 1, -4)' ;
+ like $@, mkEvalErr("^${CompressClass}::write: offset outside string");
+ }
+
+
+ {
+ title "Testing $UncompressClass Errors";
+
+ my $out = "" ;
+ eval qq[\$a = new $UncompressClass \$out ;] ;
+ like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string");
+ $out = undef ;
+ eval qq[\$a = new $UncompressClass \$out ;] ;
+ like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string");
+
+ my $lex = new LexFile my $name ;
+
+ ok ! -e $name, " $name does not exist";
+
+ eval qq[\$a = new $UncompressClass "$name" ;] ;
+ is $$UnError, "input file '$name' does not exist";
+
+ my $gc ;
+ my $guz = new $CompressClass(\$gc);
+ $guz->write("abc") ;
+ $guz->close();
+
+ my $x ;
+ my $gz = new $UncompressClass(\$gc);
+
+ foreach my $name (qw(print printf write))
+ {
+ eval " \$gz->$name() " ;
+ like $@, mkEvalErr("^$name Not Available: File opened only for intput");
+ }
+
+ }
+
+ {
+ title "Testing $CompressClass and $UncompressClass";
+
+ {
+ my ($a, $x, @x) = ("","","") ;
+
+ # Buffer not a scalar reference
+ eval qq[\$a = new $CompressClass \\\@x ;] ;
+ like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref");
+
+ # Buffer not a scalar reference
+ eval qq[\$a = new $UncompressClass \\\@x ;] ;
+ like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref");
+ }
+
+ foreach my $Type ( $CompressClass, $UncompressClass)
+ {
+ # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate
+
+ my ($a, $x, @x) = ("","","") ;
+
+ # Odd number of parameters
+ eval qq[\$a = new $Type "abc", -Output ] ;
+ like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1");
+
+ # Unknown parameter
+ eval qq[\$a = new $Type "anc", -Fred => 123 ;] ;
+ like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred");
+
+ # no in or out param
+ eval qq[\$a = new $Type ;] ;
+ like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter");
+
+ }
+
+
+ {
+ # write a very simple compressed file
+ # and read back
+ #========================================
+
+
+ my $lex = new LexFile my $name ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ {
+ my $x ;
+ ok $x = new $CompressClass $name ;
+
+ ok $x->write($hello), "write" ;
+ ok $x->flush(), "flush";
+ ok $x->close, "close" ;
+ }
+
+ {
+ my $uncomp;
+ ok my $x = new $UncompressClass $name, -Append => 1 ;
+
+ my $len ;
+ 1 while ($len = $x->read($uncomp)) > 0 ;
+
+ is $len, 0, "read returned 0"
+ or diag $$UnError ;
+
+ ok $x->close ;
+ is $uncomp, $hello ;
+ }
+ }
+
+ {
+ # write a very simple compressed file
+ # and read back
+ #========================================
+
+
+ my $lex = new LexFile my $name ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ {
+ my $x ;
+ ok $x = new $CompressClass $name ;
+
+ is $x->write(''), 0, "Write empty string is ok";
+ is $x->write(undef), 0, "Write undef is ok";
+ ok $x->write($hello), "Write ok" ;
+ ok $x->close, "Close ok" ;
+ }
+
+ {
+ my $uncomp;
+ my $x = new $UncompressClass $name ;
+ ok $x, "creates $UncompressClass $name" ;
+
+ my $data = '';
+ $data .= $uncomp while $x->read($uncomp) > 0 ;
+
+ ok $x->close, "close ok" ;
+ is $data, $hello, "expected output" ;
+ }
+ }
+
+
+ {
+ # write a very simple file with using an IO filehandle
+ # and read back
+ #========================================
+
+
+ my $lex = new LexFile my $name ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ {
+ my $fh = new IO::File ">$name" ;
+ ok $fh, "opened file $name ok";
+ my $x = new $CompressClass $fh ;
+ ok $x, " created $CompressClass $fh" ;
+
+ is $x->fileno(), fileno($fh), "fileno match" ;
+ is $x->write(''), 0, "Write empty string is ok";
+ is $x->write(undef), 0, "Write undef is ok";
+ ok $x->write($hello), "write ok" ;
+ ok $x->flush(), "flush";
+ ok $x->close,"close" ;
+ $fh->close() ;
+ }
+
+ my $uncomp;
+ {
+ my $x ;
+ ok my $fh1 = new IO::File "<$name" ;
+ ok $x = new $UncompressClass $fh1, -Append => 1 ;
+ ok $x->fileno() == fileno $fh1 ;
+
+ 1 while $x->read($uncomp) > 0 ;
+
+ ok $x->close ;
+ }
+
+ ok $hello eq $uncomp ;
+ }
+
+ {
+ # write a very simple file with using a glob filehandle
+ # and read back
+ #========================================
+
+
+ my $lex = new LexFile my $name ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ {
+ title "$CompressClass: Input from typeglob filehandle";
+ ok open FH, ">$name" ;
+
+ my $x = new $CompressClass *FH ;
+ ok $x, " create $CompressClass" ;
+
+ is $x->fileno(), fileno(*FH), " fileno" ;
+ is $x->write(''), 0, " Write empty string is ok";
+ is $x->write(undef), 0, " Write undef is ok";
+ ok $x->write($hello), " Write ok" ;
+ ok $x->flush(), " Flush";
+ ok $x->close, " Close" ;
+ close FH;
+ }
+
+
+ my $uncomp;
+ {
+ title "$UncompressClass: Input from typeglob filehandle, append output";
+ my $x ;
+ ok open FH, "<$name" ;
+ ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0
+ or diag $$UnError ;
+ is $x->fileno(), fileno FH, " fileno ok" ;
+
+ 1 while $x->read($uncomp) > 0 ;
+
+ ok $x->close, " close" ;
+ }
+ #exit;
+
+ is $uncomp, $hello, " expected output" ;
+ }
+
+ {
+ my $lex = new LexFile my $name ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ {
+ title "Outout to stdout via '-'" ;
+
+ open(SAVEOUT, ">&STDOUT");
+ my $dummy = fileno SAVEOUT;
+ open STDOUT, ">$name" ;
+
+ my $x = new $CompressClass '-' ;
+ $x->write($hello);
+ $x->close;
+
+ open(STDOUT, ">&SAVEOUT");
+
+ ok 1, " wrote to stdout" ;
+ }
+
+ {
+ title "Input from stdin via filename '-'";
+
+ my $x ;
+ my $uncomp ;
+ my $stdinFileno = fileno(STDIN);
+ # open below doesn't return 1 sometines on XP
+ open(SAVEIN, "<&STDIN");
+ ok open(STDIN, "<$name"), " redirect STDIN";
+ my $dummy = fileno SAVEIN;
+ $x = new $UncompressClass '-', Append => 1;
+ ok $x, " created object" ;
+ is $x->fileno(), $stdinFileno, " fileno ok" ;
+
+ 1 while $x->read($uncomp) > 0 ;
+
+ ok $x->close, " close" ;
+ open(STDIN, "<&SAVEIN");
+ is $uncomp, $hello, " expected output" ;
+ }
+ }
+
+ {
+ # write a compressed file to memory
+ # and read back
+ #========================================
+
+ my $name = "test.gz" ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ my $buffer ;
+ {
+ my $x ;
+ ok $x = new $CompressClass(\$buffer) ;
+
+ ok ! defined $x->fileno() ;
+ is $x->write(''), 0, "Write empty string is ok";
+ is $x->write(undef), 0, "Write undef is ok";
+ ok $x->write($hello) ;
+ ok $x->flush();
+ ok $x->close ;
+
+ writeFile($name, $buffer) ;
+ #is anyUncompress(\$buffer), $hello, " any ok";
+ }
+
+ my $keep = $buffer ;
+ my $uncomp;
+ {
+ my $x ;
+ ok $x = new $UncompressClass(\$buffer, Append => 1) ;
+
+ ok ! defined $x->fileno() ;
+ 1 while $x->read($uncomp) > 0 ;
+
+ ok $x->close ;
+ }
+
+ is $uncomp, $hello ;
+ ok $buffer eq $keep ;
+ }
+
+ if ($CompressClass ne 'RawDeflate')
+ {
+ # write empty file
+ #========================================
+
+ my $buffer = '';
+ {
+ my $x ;
+ ok $x = new $CompressClass(\$buffer) ;
+ ok $x->close ;
+
+ }
+
+ my $keep = $buffer ;
+ my $uncomp= '';
+ {
+ my $x ;
+ ok $x = new $UncompressClass(\$buffer, Append => 1) ;
+
+ 1 while $x->read($uncomp) > 0 ;
+
+ ok $x->close ;
+ }
+
+ ok $uncomp eq '' ;
+ ok $buffer eq $keep ;
+
+ }
+
+ {
+ # write a larger file
+ #========================================
+
+
+ my $lex = new LexFile my $name ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ my $input = '' ;
+ my $contents = '' ;
+
+ {
+ my $x = new $CompressClass $name ;
+ ok $x, " created $CompressClass object";
+
+ ok $x->write($hello), " write ok" ;
+ $input .= $hello ;
+ ok $x->write("another line"), " write ok" ;
+ $input .= "another line" ;
+ # all characters
+ foreach (0 .. 255)
+ { $contents .= chr int $_ }
+ # generate a long random string
+ foreach (1 .. 5000)
+ { $contents .= chr int rand 256 }
+
+ ok $x->write($contents), " write ok" ;
+ $input .= $contents ;
+ ok $x->close, " close ok" ;
+ }
+
+ ok myGZreadFile($name) eq $input ;
+ my $x = readFile($name) ;
+ #print "length " . length($x) . " \n";
+ }
+
+ {
+ # embed a compressed file in another file
+ #================================
+
+
+ my $lex = new LexFile my $name ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ my $header = "header info\n" ;
+ my $trailer = "trailer data\n" ;
+
+ {
+ my $fh ;
+ ok $fh = new IO::File ">$name" ;
+ print $fh $header ;
+ my $x ;
+ ok $x = new $CompressClass $fh,
+ -AutoClose => 0 ;
+
+ ok $x->binmode();
+ ok $x->write($hello) ;
+ ok $x->close ;
+ print $fh $trailer ;
+ $fh->close() ;
+ }
+
+ my ($fil, $uncomp) ;
+ my $fh1 ;
+ ok $fh1 = new IO::File "<$name" ;
+ # skip leading junk
+ my $line = <$fh1> ;
+ ok $line eq $header ;
+
+ ok my $x = new $UncompressClass $fh1, Append => 1 ;
+ ok $x->binmode();
+ 1 while $x->read($uncomp) > 0 ;
+
+ ok $uncomp eq $hello ;
+ my $rest ;
+ read($fh1, $rest, 5000);
+ is $x->trailingData() . $rest, $trailer ;
+ #print "# [".$x->trailingData() . "][$rest]\n" ;
+ #exit;
+
+ }
+
+ {
+ # Write
+ # these tests come almost 100% from IO::String
+
+ my $lex = new LexFile my $name ;
+
+ my $io = $CompressClass->new($name);
+
+ is $io->tell(), 0, " tell returns 0"; ;
+
+ my $heisan = "Heisan\n";
+ $io->print($heisan) ;
+
+ ok ! $io->eof(), " ! eof";
+
+ is $io->tell(), length($heisan), " tell is " . length($heisan) ;
+
+ $io->print("a", "b", "c");
+
+ {
+ local($\) = "\n";
+ $io->print("d", "e");
+ local($,) = ",";
+ $io->print("f", "g", "h");
+ }
+
+ {
+ local($\) ;
+ $io->print("D", "E");
+ local($,) = ".";
+ $io->print("F", "G", "H");
+ }
+
+ my $foo = "1234567890";
+
+ is $io->syswrite($foo, length($foo)), length($foo), " syswrite ok" ;
+ if ( $[ < 5.6 )
+ { is $io->syswrite($foo, length $foo), length $foo, " syswrite ok" }
+ else
+ { is $io->syswrite($foo), length $foo, " syswrite ok" }
+ is $io->syswrite($foo, length($foo)), length $foo, " syswrite ok";
+ is $io->write($foo, length($foo), 5), 5, " write 5";
+ is $io->write("xxx\n", 100, -1), 1, " write 1";
+
+ for (1..3) {
+ $io->printf("i(%d)", $_);
+ $io->printf("[%d]\n", $_);
+ }
+ $io->print("\n");
+
+ $io->close ;
+
+ ok $io->eof(), " eof";
+
+ is myGZreadFile($name), "Heisan\nabcde\nf,g,h\nDEF.G.H" .
+ ("1234567890" x 3) . "67890\n" .
+ "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
+
+
+ }
+
+ {
+ # Read
+ my $str = <<EOT;
+This is an example
+of a paragraph
+
+
+and a single line.
+
+EOT
+
+ my $lex = new LexFile my $name ;
+
+ my %opts = () ;
+ my $iow = new $CompressClass $name, %opts;
+ $iow->print($str) ;
+ $iow->close ;
+
+ my @tmp;
+ my $buf;
+ {
+ my $io = new $UncompressClass $name ;
+
+ ok ! $io->eof;
+ is $io->tell(), 0 ;
+ #my @lines = <$io>;
+ my @lines = $io->getlines();
+ is @lines, 6
+ or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
+ is $lines[1], "of a paragraph\n" ;
+ is join('', @lines), $str ;
+ is $., 6;
+ is $io->tell(), length($str) ;
+
+ ok $io->eof;
+
+ ok ! ( defined($io->getline) ||
+ (@tmp = $io->getlines) ||
+ defined($io->getline) ||
+ defined($io->getc) ||
+ $io->read($buf, 100) != 0) ;
+ }
+
+
+ {
+ local $/; # slurp mode
+ my $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my @lines = $io->getlines;
+ ok $io->eof;
+ ok @lines == 1 && $lines[0] eq $str;
+
+ $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my $line = $io->getline();
+ ok $line eq $str;
+ ok $io->eof;
+ }
+
+ {
+ local $/ = ""; # paragraph mode
+ my $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my @lines = $io->getlines();
+ ok $io->eof;
+ ok @lines == 2
+ or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
+ ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
+ or print "# $lines[0]\n";
+ ok $lines[1] eq "and a single line.\n\n";
+ }
+
+ {
+ local $/ = "is";
+ my $io = $UncompressClass->new($name);
+ my @lines = ();
+ my $no = 0;
+ my $err = 0;
+ ok ! $io->eof;
+ while (my $a = $io->getline()) {
+ push(@lines, $a);
+ $err++ if $. != ++$no;
+ }
+
+ ok $err == 0 ;
+ ok $io->eof;
+
+ ok @lines == 3
+ or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
+ ok join("-", @lines) eq
+ "This- is- an example\n" .
+ "of a paragraph\n\n\n" .
+ "and a single line.\n\n";
+ }
+
+
+ # Test read
+
+ {
+ my $io = $UncompressClass->new($name);
+
+
+ eval { $io->read(1) } ;
+ like $@, mkErr("buffer parameter is read-only");
+
+ is $io->read($buf, 0), 0, "Requested 0 bytes" ;
+
+ ok $io->read($buf, 3) == 3 ;
+ ok $buf eq "Thi";
+
+ ok $io->sysread($buf, 3, 2) == 3 ;
+ ok $buf eq "Ths i"
+ or print "# [$buf]\n" ;;
+ ok ! $io->eof;
+
+ # $io->seek(-4, 2);
+ #
+ # ok ! $io->eof;
+ #
+ # ok read($io, $buf, 20) == 4 ;
+ # ok $buf eq "e.\n\n";
+ #
+ # ok read($io, $buf, 20) == 0 ;
+ # ok $buf eq "";
+ #
+ # ok ! $io->eof;
+ }
+
+ }
+
+ {
+ # Read from non-compressed file
+
+ my $str = <<EOT;
+This is an example
+of a paragraph
+
+
+and a single line.
+
+EOT
+
+ my $lex = new LexFile my $name ;
+
+ writeFile($name, $str);
+ my @tmp;
+ my $buf;
+ {
+ my $io = new $UncompressClass $name, -Transparent => 1 ;
+
+ ok defined $io;
+ ok ! $io->eof;
+ ok $io->tell() == 0 ;
+ my @lines = $io->getlines();
+ ok @lines == 6;
+ ok $lines[1] eq "of a paragraph\n" ;
+ ok join('', @lines) eq $str ;
+ ok $. == 6;
+ ok $io->tell() == length($str) ;
+
+ ok $io->eof;
+
+ ok ! ( defined($io->getline) ||
+ (@tmp = $io->getlines) ||
+ defined($io->getline) ||
+ defined($io->getc) ||
+ $io->read($buf, 100) != 0) ;
+ }
+
+
+ {
+ local $/; # slurp mode
+ my $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my @lines = $io->getlines;
+ ok $io->eof;
+ ok @lines == 1 && $lines[0] eq $str;
+
+ $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my $line = $io->getline;
+ ok $line eq $str;
+ ok $io->eof;
+ }
+
+ {
+ local $/ = ""; # paragraph mode
+ my $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my @lines = $io->getlines;
+ ok $io->eof;
+ ok @lines == 2
+ or print "# exected 2 lines, got " . scalar(@lines) . "\n";
+ ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
+ or print "# [$lines[0]]\n" ;
+ ok $lines[1] eq "and a single line.\n\n";
+ }
+
+ {
+ local $/ = "is";
+ my $io = $UncompressClass->new($name);
+ my @lines = ();
+ my $no = 0;
+ my $err = 0;
+ ok ! $io->eof;
+ while (my $a = $io->getline) {
+ push(@lines, $a);
+ $err++ if $. != ++$no;
+ }
+
+ ok $err == 0 ;
+ ok $io->eof;
+
+ ok @lines == 3 ;
+ ok join("-", @lines) eq
+ "This- is- an example\n" .
+ "of a paragraph\n\n\n" .
+ "and a single line.\n\n";
+ }
+
+
+ # Test read
+
+ {
+ my $io = $UncompressClass->new($name);
+
+ ok $io->read($buf, 3) == 3 ;
+ ok $buf eq "Thi";
+
+ ok $io->sysread($buf, 3, 2) == 3 ;
+ ok $buf eq "Ths i";
+ ok ! $io->eof;
+
+ # $io->seek(-4, 2);
+ #
+ # ok ! $io->eof;
+ #
+ # ok read($io, $buf, 20) == 4 ;
+ # ok $buf eq "e.\n\n";
+ #
+ # ok read($io, $buf, 20) == 0 ;
+ # ok $buf eq "";
+ #
+ # ok ! $io->eof;
+ }
+
+
+ }
+
+ {
+ # Vary the length parameter in a read
+
+ my $str = <<EOT;
+x
+x
+This is an example
+of a paragraph
+
+
+and a single line.
+
+EOT
+ $str = $str x 100 ;
+
+
+ foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
+ {
+ foreach my $trans (0, 1)
+ {
+ foreach my $append (0, 1)
+ {
+ title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
+
+ my $lex = new LexFile my $name ;
+
+ if ($trans) {
+ writeFile($name, $str) ;
+ }
+ else {
+ my $iow = new $CompressClass $name;
+ $iow->print($str) ;
+ $iow->close ;
+ }
+
+
+ my $io = $UncompressClass->new($name,
+ -Append => $append,
+ -Transparent => $trans);
+
+ my $buf;
+
+ is $io->tell(), 0;
+
+ if ($append) {
+ 1 while $io->read($buf, $bufsize) > 0;
+ }
+ else {
+ my $tmp ;
+ $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
+ }
+ is length $buf, length $str;
+ ok $buf eq $str ;
+ ok ! $io->error() ;
+ ok $io->eof;
+ }
+ }
+ }
+ }
+
+ foreach my $file (0, 1)
+ {
+ foreach my $trans (0, 1)
+ {
+ title "seek tests - file $file trans $trans" ;
+
+ my $buffer ;
+ my $buff ;
+ my $lex = new LexFile my $name ;
+
+ my $first = "beginning" ;
+ my $last = "the end" ;
+
+ if ($trans)
+ {
+ $buffer = $first . "\x00" x 10 . $last;
+ writeFile($name, $buffer);
+ }
+ else
+ {
+ my $output ;
+ if ($file)
+ {
+ $output = $name ;
+ }
+ else
+ {
+ $output = \$buffer;
+ }
+
+ my $iow = new $CompressClass $output ;
+ $iow->print($first) ;
+ ok $iow->seek(5, SEEK_CUR) ;
+ ok $iow->tell() == length($first)+5;
+ ok $iow->seek(0, SEEK_CUR) ;
+ ok $iow->tell() == length($first)+5;
+ ok $iow->seek(length($first)+10, SEEK_SET) ;
+ ok $iow->tell() == length($first)+10;
+
+ $iow->print($last) ;
+ $iow->close ;
+ }
+
+ my $input ;
+ if ($file)
+ {
+ $input = $name ;
+ }
+ else
+ {
+ $input = \$buffer ;
+ }
+
+ ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ;
+
+ my $io = $UncompressClass->new($input, Strict => 1);
+ ok $io->seek(length($first), SEEK_CUR) ;
+ ok ! $io->eof;
+ is $io->tell(), length($first);
+
+ ok $io->read($buff, 5) ;
+ is $buff, "\x00" x 5 ;
+ is $io->tell(), length($first) + 5;
+
+ ok $io->seek(0, SEEK_CUR) ;
+ my $here = $io->tell() ;
+ is $here, length($first)+5;
+
+ ok $io->seek($here+5, SEEK_SET) ;
+ is $io->tell(), $here+5 ;
+ ok $io->read($buff, 100) ;
+ ok $buff eq $last ;
+ ok $io->eof;
+ }
+ }
+
+ {
+ title "seek error cases" ;
+
+ my $b ;
+ my $a = new $CompressClass(\$b) ;
+
+ ok ! $a->error() ;
+ eval { $a->seek(-1, 10) ; };
+ like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter");
+
+ eval { $a->seek(-1, SEEK_END) ; };
+ like $@, mkErr("^${CompressClass}::seek: cannot seek backwards");
+
+ $a->write("fred");
+ $a->close ;
+
+
+ my $u = new $UncompressClass(\$b) ;
+
+ eval { $u->seek(-1, 10) ; };
+ like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter");
+
+ eval { $u->seek(-1, SEEK_END) ; };
+ like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed");
+
+ eval { $u->seek(-1, SEEK_CUR) ; };
+ like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards");
+ }
+
+ foreach my $fb (qw(filename buffer filehandle))
+ {
+ foreach my $append (0, 1)
+ {
+ {
+ title "$CompressClass -- Append $append, Output to $fb" ;
+
+ my $lex = new LexFile my $name ;
+
+ my $already = 'already';
+ my $buffer = $already;
+ my $output;
+
+ if ($fb eq 'buffer')
+ { $output = \$buffer }
+ elsif ($fb eq 'filename')
+ {
+ $output = $name ;
+ writeFile($name, $buffer);
+ }
+ elsif ($fb eq 'filehandle')
+ {
+ $output = new IO::File ">$name" ;
+ print $output $buffer;
+ }
+
+ my $a = new $CompressClass($output, Append => $append) ;
+ ok $a, " Created $CompressClass";
+ my $string = "appended";
+ $a->write($string);
+ $a->close ;
+
+ my $data ;
+ if ($fb eq 'buffer')
+ {
+ $data = $buffer;
+ }
+ else
+ {
+ $output->close
+ if $fb eq 'filehandle';
+ $data = readFile($name);
+ }
+
+ if ($append || $fb eq 'filehandle')
+ {
+ is substr($data, 0, length($already)), $already, " got prefix";
+ substr($data, 0, length($already)) = '';
+ }
+
+
+ my $uncomp;
+ my $x = new $UncompressClass(\$data, Append => 1) ;
+ ok $x, " created $UncompressClass";
+
+ my $len ;
+ 1 while ($len = $x->read($uncomp)) > 0 ;
+
+ $x->close ;
+ is $uncomp, $string, ' Got uncompressed data' ;
+
+ }
+ }
+ }
+
+ foreach my $type (qw(buffer filename filehandle))
+ {
+ title "$UncompressClass -- InputLength, read from $type";
+
+ my $compressed ;
+ my $string = "some data";
+ my $c = new $CompressClass(\$compressed);
+ $c->write($string);
+ $c->close();
+
+ my $appended = "append";
+ my $comp_len = length $compressed;
+ $compressed .= $appended;
+
+ my $lex = new LexFile my $name ;
+ my $input ;
+ writeFile ($name, $compressed);
+
+ if ($type eq 'buffer')
+ {
+ $input = \$compressed;
+ }
+ if ($type eq 'filename')
+ {
+ $input = $name;
+ }
+ elsif ($type eq 'filehandle')
+ {
+ my $fh = new IO::File "<$name" ;
+ ok $fh, "opened file $name ok";
+ $input = $fh ;
+ }
+
+ my $x = new $UncompressClass($input, InputLength => $comp_len) ;
+ ok $x, " created $UncompressClass";
+
+ my $len ;
+ my $output;
+ $len = $x->read($output, 100);
+ is $len, length($string);
+ is $output, $string;
+
+ if ($type eq 'filehandle')
+ {
+ my $rest ;
+ $input->read($rest, 1000);
+ is $rest, $appended;
+ }
+
+
+ }
+
+ foreach my $append (0, 1)
+ {
+ title "$UncompressClass -- Append $append" ;
+
+ my $lex = new LexFile my $name ;
+
+ my $string = "appended";
+ my $compressed ;
+ my $c = new $CompressClass(\$compressed);
+ $c->write($string);
+ $c->close();
+
+ my $x = new $UncompressClass(\$compressed, Append => $append) ;
+ ok $x, " created $UncompressClass";
+
+ my $already = 'already';
+ my $output = $already;
+
+ my $len ;
+ $len = $x->read($output, 100);
+ is $len, length($string);
+
+ $x->close ;
+
+ if ($append)
+ {
+ is substr($output, 0, length($already)), $already, " got prefix";
+ substr($output, 0, length($already)) = '';
+ }
+ is $output, $string, ' Got uncompressed data' ;
+ }
+
+
+ foreach my $file (0, 1)
+ {
+ foreach my $trans (0, 1)
+ {
+ title "ungetc, File $file, Transparent $trans" ;
+
+ my $lex = new LexFile my $name ;
+
+ my $string = 'abcdeABCDE';
+ my $b ;
+ if ($trans)
+ {
+ $b = $string ;
+ }
+ else
+ {
+ my $a = new $CompressClass(\$b) ;
+ $a->write($string);
+ $a->close ;
+ }
+
+ my $from ;
+ if ($file)
+ {
+ writeFile($name, $b);
+ $from = $name ;
+ }
+ else
+ {
+ $from = \$b ;
+ }
+
+ my $u = $UncompressClass->new($from, Transparent => 1) ;
+ my $first;
+ my $buff ;
+
+ # do an ungetc before reading
+ $u->ungetc("X");
+ $first = $u->getc();
+ is $first, 'X';
+
+ $first = $u->getc();
+ is $first, substr($string, 0,1);
+ $u->ungetc($first);
+ $first = $u->getc();
+ is $first, substr($string, 0,1);
+ $u->ungetc($first);
+
+ is $u->read($buff, 5), 5 ;
+ is $buff, substr($string, 0, 5);
+
+ $u->ungetc($buff) ;
+ is $u->read($buff, length($string)), length($string) ;
+ is $buff, $string;
+
+ is $u->read($buff, 1), 0;
+ ok $u->eof() ;
+
+ my $extra = 'extra';
+ $u->ungetc($extra);
+ ok ! $u->eof();
+ is $u->read($buff), length($extra) ;
+ is $buff, $extra;
+
+ is $u->read($buff, 1), 0;
+ ok $u->eof() ;
+
+ $u->close();
+
+ }
+ }
+
+
+ {
+ title "write tests - invalid data" ;
+
+ #my $lex = new LexFile my $name1 ;
+ my($Answer);
+
+ #ok ! -e $name1, " File $name1 does not exist";
+
+ my @data = (
+ [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
+ [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
+ [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
+ [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ],
+ [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ],
+ [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ],
+ #[ "not readable", 'xx' ],
+ # same filehandle twice, 'xx'
+ ) ;
+
+ foreach my $data (@data)
+ {
+ my ($send, $get) = @$data ;
+ title "${CompressClass}::write( $send )";
+ my($copy);
+ eval "\$copy = $send";
+ my $x = new $CompressClass(\$Answer);
+ ok $x, " Created $CompressClass object";
+ eval { $x->write($copy) } ;
+ #like $@, "/^$get/", " error - $get";
+ like $@, "/not a scalar reference /", " error - not a scalar reference";
+ }
+
+ # @data = (
+ # [ '[ $name1 ]', "input file '$name1' does not exist" ],
+ # #[ "not readable", 'xx' ],
+ # # same filehandle twice, 'xx'
+ # ) ;
+ #
+ # foreach my $data (@data)
+ # {
+ # my ($send, $get) = @$data ;
+ # title "${CompressClass}::write( $send )";
+ # my $copy;
+ # eval "\$copy = $send";
+ # my $x = new $CompressClass(\$Answer);
+ # ok $x, " Created $CompressClass object";
+ # ok ! $x->write($copy), " write fails" ;
+ # like $$Error, "/^$get/", " error - $get";
+ # }
+
+ #exit;
+
+ }
+
+
+ # sub deepCopy
+ # {
+ # if (! ref $_[0] || ref $_[0] eq 'SCALAR')
+ # {
+ # return $_[0] ;
+ # }
+ #
+ # if (ref $_[0] eq 'ARRAY')
+ # {
+ # my @a ;
+ # for my $x ( @{ $_[0] })
+ # {
+ # push @a, deepCopy($x);
+ # }
+ #
+ # return \@a ;
+ # }
+ #
+ # croak "bad! $_[0]";
+ #
+ # }
+ #
+ # sub deepSubst
+ # {
+ # #my $data = shift ;
+ # my $from = $_[1] ;
+ # my $to = $_[2] ;
+ #
+ # if (! ref $_[0])
+ # {
+ # $_[0] = $to
+ # if $_[0] eq $from ;
+ # return ;
+ #
+ # }
+ #
+ # if (ref $_[0] eq 'SCALAR')
+ # {
+ # $_[0] = \$to
+ # if defined ${ $_[0] } && ${ $_[0] } eq $from ;
+ # return ;
+ #
+ # }
+ #
+ # if (ref $_[0] eq 'ARRAY')
+ # {
+ # for my $x ( @{ $_[0] })
+ # {
+ # deepSubst($x, $from, $to);
+ # }
+ # return ;
+ # }
+ # #croak "bad! $_[0]";
+ # }
+
+ # {
+ # title "More write tests" ;
+ #
+ # my $file1 = "file1" ;
+ # my $file2 = "file2" ;
+ # my $file3 = "file3" ;
+ # my $lex = new LexFile $file1, $file2, $file3 ;
+ #
+ # writeFile($file1, "F1");
+ # writeFile($file2, "F2");
+ # writeFile($file3, "F3");
+ #
+ # my @data = (
+ # [ '""', "" ],
+ # [ 'undef', "" ],
+ # [ '"abcd"', "abcd" ],
+ #
+ # [ '\""', "" ],
+ # [ '\undef', "" ],
+ # [ '\"abcd"', "abcd" ],
+ #
+ # [ '[]', "" ],
+ # [ '[[]]', "" ],
+ # [ '[[[]]]', "" ],
+ # [ '[\""]', "" ],
+ # [ '[\undef]', "" ],
+ # [ '[\"abcd"]', "abcd" ],
+ # [ '[\"ab", \"cd"]', "abcd" ],
+ # [ '[[\"ab"], [\"cd"]]', "abcd" ],
+ #
+ # [ '$file1', $file1 ],
+ # [ '$fh2', "F2" ],
+ # [ '[$file1, \"abc"]', "F1abc"],
+ # [ '[\"a", $file1, \"bc"]', "aF1bc"],
+ # [ '[\"a", $fh1, \"bc"]', "aF1bc"],
+ # [ '[\"a", $fh1, \"bc", $file2]', "aF1bcF2"],
+ # [ '[\"a", $fh1, \"bc", $file2, $fh3]', "aF1bcF2F3"],
+ # ) ;
+ #
+ #
+ # foreach my $data (@data)
+ # {
+ # my ($send, $get) = @$data ;
+ #
+ # my $fh1 = new IO::File "< $file1" ;
+ # my $fh2 = new IO::File "< $file2" ;
+ # my $fh3 = new IO::File "< $file3" ;
+ #
+ # title "${CompressClass}::write( $send )";
+ # my $copy;
+ # eval "\$copy = $send";
+ # my $Answer ;
+ # my $x = new $CompressClass(\$Answer);
+ # ok $x, " Created $CompressClass object";
+ # my $len = length $get;
+ # is $x->write($copy), length($get), " write $len bytes";
+ # ok $x->close(), " close ok" ;
+ #
+ # is myGZreadFile(\$Answer), $get, " got expected output" ;
+ # cmp_ok $$Error, '==', 0, " no error";
+ #
+ #
+ # }
+ #
+ # }
+ }
+
+}
+
+1;
+
+
+
+
--- /dev/null
+use lib 't';
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+use Compress::Zlib 2 ;
+
+BEGIN
+{
+ plan(skip_all => "Merge needs Zlib 1.2.1 or better - you have Zlib "
+ . Compress::Zlib::zlib_version())
+ if ZLIB_VERNUM() < 0x1210 ;
+
+ # use Test::NoWarnings, if available
+ my $extra = 0 ;
+ $extra = 1
+ if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
+
+ plan tests => 166 + $extra ;
+
+}
+
+
+sub run
+{
+
+ my $CompressClass = identify();
+ my $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+
+
+
+ # Check zlib_version and ZLIB_VERSION are the same.
+ is Compress::Zlib::zlib_version, ZLIB_VERSION,
+ "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
+
+ # Tests
+ # destination is a file that doesn't exist -- should work ok unless AnyDeflate
+ # destination isn't compressed at all
+ # destination is compressed but wrong format
+ # destination is corrupt - error messages should be correct
+ # use apend mode with old zlib - check that this is trapped
+ # destination is not seekable, readable, writable - test for filename & handle
+
+ {
+ title "Misc error cases";
+
+ eval { new Compress::Zlib::InflateScan Bufsize => 0} ;
+ like $@, mkErr("^Compress::Zlib::InflateScan::new: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0";
+
+ eval { Compress::Zlib::inflateScanStream::createDeflateStream(undef, Bufsize => 0) } ;
+ like $@, mkErr("^Compress::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0";
+
+ }
+
+ # output file/handle not writable
+ {
+
+ foreach my $to_file (0,1)
+ {
+ if ($to_file)
+ { title "$CompressClass - Merge to filename that isn't writable" }
+ else
+ { title "$CompressClass - Merge to filehandle that isn't writable" }
+
+ my $lex = new LexFile my $out_file ;
+
+ # create empty file
+ open F, ">$out_file" ; print F "x"; close F;
+ ok -e $out_file, " file exists" ;
+ ok !-z $out_file, " and is not empty" ;
+
+ # make unwritable
+ is chmod(0444, $out_file), 1, " chmod worked" ;
+ ok -e $out_file, " still exists after chmod" ;
+
+ SKIP:
+ {
+ skip "Cannot create non-writable file", 3
+ if -w $out_file ;
+
+ ok ! -w $out_file, " chmod made file unwritable" ;
+
+ my $dest ;
+ if ($to_file)
+ { $dest = $out_file }
+ else
+ { $dest = new IO::File "<$out_file" }
+
+ my $gz = $CompressClass->new($dest, Merge => 1) ;
+
+ ok ! $gz, " Did not create $CompressClass object";
+
+ {
+ if ($to_file) {
+ is $$Error, "Output file '$out_file' is not writable",
+ " Got non-writable filename message" ;
+ }
+ else {
+ is $$Error, "Output filehandle is not writable",
+ " Got non-writable filehandle message" ;
+ }
+ }
+ }
+
+ chmod 0777, $out_file ;
+ }
+ }
+
+ # output is not compressed at all
+ {
+
+ my $lex = new LexFile my $out_file ;
+
+ foreach my $to_file ( qw(buffer file handle ) )
+ {
+ title "$CompressClass to $to_file, content is not compressed";
+
+ my $content = "abc" x 300 ;
+ my $buffer ;
+ my $disp_content = defined $content ? $content : '<undef>' ;
+ my $str_content = defined $content ? $content : '' ;
+
+ if ($to_file eq 'buffer')
+ {
+ $buffer = \$content ;
+ }
+ else
+ {
+ writeFile($out_file, $content);
+
+ if ($to_file eq 'handle')
+ {
+ $buffer = new IO::File "+<$out_file"
+ or die "# Cannot open $out_file: $!";
+ }
+ else
+ { $buffer = $out_file }
+ }
+
+ ok ! $CompressClass->new($buffer, Merge => 1), " constructor fails";
+ {
+ like $$Error, '/Cannot create InflateScan object: (Header Error|unexpected end of file)/', " got Bad Magic" ;
+ }
+
+ }
+ }
+
+ # output is empty
+ {
+
+ my $lex = new LexFile my $out_file ;
+
+ foreach my $to_file ( qw(buffer file handle ) )
+ {
+ title "$CompressClass to $to_file, content is empty";
+
+ my $content = '';
+ my $buffer ;
+ my $dest ;
+
+ if ($to_file eq 'buffer')
+ {
+ $dest = $buffer = \$content ;
+ }
+ else
+ {
+ writeFile($out_file, $content);
+ $dest = $out_file;
+
+ if ($to_file eq 'handle')
+ {
+ $buffer = new IO::File "+<$out_file"
+ or die "# Cannot open $out_file: $!";
+ }
+ else
+ { $buffer = $out_file }
+ }
+
+ ok my $gz = $CompressClass->new($buffer, Merge => 1, AutoClose => 1), " constructor passes"
+ or diag $$Error;
+
+ $gz->write("FGHI");
+ $gz->close();
+
+ #hexDump($buffer);
+ my $out = anyUncompress($dest);
+
+ is $out, "FGHI", ' Merge OK';
+ }
+ }
+
+ {
+ title "$CompressClass - Merge to file that doesn't exist";
+
+ my $lex = new LexFile my $out_file ;
+
+ ok ! -e $out_file, " Destination file, '$out_file', does not exist";
+
+ ok my $gz1 = $CompressClass->new($out_file, Merge => 1)
+ or die "# $CompressClass->new failed: $$Error\n";
+ #hexDump($buffer);
+ $gz1->write("FGHI");
+ $gz1->close();
+
+ #hexDump($buffer);
+ my $out = anyUncompress($out_file);
+
+ is $out, "FGHI", ' Merged OK';
+ }
+
+ {
+
+ my $lex = new LexFile my $out_file ;
+
+ foreach my $to_file ( qw( buffer file handle ) )
+ {
+ foreach my $content (undef, '', 'x', 'abcde')
+ {
+ #next if ! defined $content && $to_file;
+
+ my $buffer ;
+ my $disp_content = defined $content ? $content : '<undef>' ;
+ my $str_content = defined $content ? $content : '' ;
+
+ if ($to_file eq 'buffer')
+ {
+ my $x ;
+ $buffer = \$x ;
+ title "$CompressClass to Buffer, content is '$disp_content'";
+ }
+ else
+ {
+ $buffer = $out_file ;
+ if ($to_file eq 'handle')
+ {
+ title "$CompressClass to Filehandle, content is '$disp_content'";
+ }
+ else
+ {
+ title "$CompressClass to File, content is '$disp_content'";
+ }
+ }
+
+ my $gz = $CompressClass->new($buffer);
+ my $len = defined $content ? length($content) : 0 ;
+ is $gz->write($content), $len, " write ok";
+ ok $gz->close(), " close ok";
+
+ #hexDump($buffer);
+ is anyUncompress($buffer), $str_content, ' Destination is ok';
+
+ #if ($corruption)
+ #{
+ # next if $TopTypes eq 'RawDeflate' && $content eq '';
+ #
+ #}
+
+ my $dest = $buffer ;
+ if ($to_file eq 'handle')
+ {
+ $dest = new IO::File "+<$buffer" ;
+ }
+
+ my $gz1 = $CompressClass->new($dest, Merge => 1, AutoClose => 1)
+ or die "## Error is $$Error\n";
+
+ #print "YYY\n";
+ #hexDump($buffer);
+ #print "XXX\n";
+ is $gz1->write("FGHI"), 4, " write returned 4";
+ ok $gz1->close(), " close ok";
+
+ #hexDump($buffer);
+ my $out = anyUncompress($buffer);
+
+ is $out, $str_content . "FGHI", ' Merged OK';
+ #exit;
+ }
+ }
+
+ }
+
+
+
+ {
+ my $Func = getTopFuncRef($CompressClass);
+ my $TopType = getTopFuncName($CompressClass);
+
+ my $buffer ;
+
+ my $lex = new LexFile my $out_file ;
+
+ foreach my $to_file (0, 1)
+ {
+ foreach my $content (undef, '', 'x', 'abcde')
+ {
+ my $disp_content = defined $content ? $content : '<undef>' ;
+ my $str_content = defined $content ? $content : '' ;
+ my $buffer ;
+ if ($to_file)
+ {
+ $buffer = $out_file ;
+ title "$TopType to File, content is '$disp_content'";
+ }
+ else
+ {
+ my $x = '';
+ $buffer = \$x ;
+ title "$TopType to Buffer, content is '$disp_content'";
+ }
+
+
+ ok $Func->(\$content, $buffer), " Compress content";
+ #hexDump($buffer);
+ is anyUncompress($buffer), $str_content, ' Destination is ok';
+
+
+ ok $Func->(\"FGHI", $buffer, Merge => 1), " Merge content";
+
+ #hexDump($buffer);
+ my $out = anyUncompress($buffer);
+
+ is $out, $str_content . "FGHI", ' Merged OK';
+ }
+ }
+
+ }
+
+}
+
+
+1;
--- /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 => 190 + $extra ;
+
+ use_ok('IO::Uncompress::AnyUncompress', qw($AnyUncompressError)) ;
+
+}
+
+sub run
+{
+
+ my $CompressClass = identify();
+ my $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+
+
+
+ my @buffers ;
+ push @buffers, <<EOM ;
+hello world
+this is a test
+some more stuff on this line
+ad finally...
+EOM
+
+ push @buffers, <<EOM ;
+some more stuff
+EOM
+
+ push @buffers, <<EOM ;
+even more stuff
+EOM
+
+ {
+ my $cc ;
+ my $gz ;
+ my $hsize ;
+ my %headers = () ;
+
+
+ foreach my $fb ( qw( file filehandle buffer ) )
+ {
+
+ foreach my $i (1 .. @buffers) {
+
+ title "Testing $CompressClass with $i streams to $fb";
+
+ my @buffs = @buffers[0..$i -1] ;
+
+ if ($CompressClass eq 'IO::Compress::Gzip') {
+ %headers = (
+ Strict => 0,
+ Comment => "this is a comment",
+ ExtraField => "some extra",
+ HeaderCRC => 1);
+
+ }
+
+ my $lex = new LexFile my $name ;
+ my $output ;
+ if ($fb eq 'buffer')
+ {
+ my $compressed = '';
+ $output = \$compressed;
+ }
+ elsif ($fb eq 'filehandle')
+ {
+ $output = new IO::File ">$name" ;
+ }
+ else
+ {
+ $output = $name ;
+ }
+
+ my $x = new $CompressClass($output, AutoClose => 1, %headers);
+ isa_ok $x, $CompressClass, ' $x' ;
+
+ foreach my $buffer (@buffs) {
+ ok $x->write($buffer), " Write OK" ;
+ # this will add an extra "empty" stream
+ ok $x->newStream(), " newStream OK" ;
+ }
+ ok $x->close, " Close ok" ;
+
+ #hexDump($compressed) ;
+
+ foreach my $unc ($UncompressClass, 'IO::Uncompress::AnyUncompress') {
+ title " Testing $CompressClass with $unc and $i streams, from $fb";
+ $cc = $output ;
+ if ($fb eq 'filehandle')
+ {
+ $cc = new IO::File "<$name" ;
+ }
+ my $gz = new $unc($cc,
+ Strict => 0,
+ AutoClose => 1,
+ Append => 1,
+ MultiStream => 1,
+ Transparent => 0);
+ isa_ok $gz, $UncompressClass, ' $gz' ;
+
+ my $un = '';
+ 1 while $gz->read($un) > 0 ;
+ #print "[[$un]]\n" while $gz->read($un) > 0 ;
+ ok ! $gz->error(), " ! error()"
+ or diag "Error is " . $gz->error() ;
+ ok $gz->eof(), " eof()";
+ ok $gz->close(), " close() ok"
+ or diag "errno $!\n" ;
+
+ is $gz->streamCount(), $i +1, " streamCount ok"
+ or diag "Stream count is " . $gz->streamCount();
+ ok $un eq join('', @buffs), " expected output" ;
+
+ }
+ }
+ }
+ }
+}
+
+
+# corrupt one of the streams - all previous should be ok
+# trailing stuff
+# need a way to skip to the start of the next stream.
+# check that "tell" works ok
+
+1;
--- /dev/null
+use lib 't';
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+our ($BadPerl, $UncompressClass);
+
+BEGIN
+{
+ plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" )
+ if $] < 5.006 ;
+
+ my $tests ;
+
+ $BadPerl = ($] >= 5.006 and $] <= 5.008) ;
+
+ if ($BadPerl) {
+ $tests = 78 ;
+ }
+ else {
+ $tests = 84 ;
+ }
+
+ # use Test::NoWarnings, if available
+ my $extra = 0 ;
+ $extra = 1
+ if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
+
+ plan tests => $tests + $extra ;
+
+}
+
+
+use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+
+
+
+sub myGZreadFile
+{
+ my $filename = shift ;
+ my $init = shift ;
+
+
+ my $fil = new $UncompressClass $filename,
+ -Strict => 1,
+ -Append => 1
+ ;
+
+ my $data ;
+ $data = $init if defined $init ;
+ 1 while $fil->read($data) > 0;
+
+ $fil->close ;
+ return $data ;
+}
+
+
+sub run
+{
+
+ my $CompressClass = identify();
+ $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+ {
+ title "Testing $CompressClass and $UncompressClass";
+
+
+
+ {
+ # Write
+ # these tests come almost 100% from IO::String
+
+ my $lex = new LexFile my $name ;
+
+ my $io = $CompressClass->new($name);
+
+ is tell($io), 0 ;
+ is $io->tell(), 0 ;
+
+ my $heisan = "Heisan\n";
+ print $io $heisan ;
+
+ ok ! eof($io);
+ ok ! $io->eof();
+
+ is tell($io), length($heisan) ;
+ is $io->tell(), length($heisan) ;
+
+ $io->print("a", "b", "c");
+
+ {
+ local($\) = "\n";
+ print $io "d", "e";
+ local($,) = ",";
+ print $io "f", "g", "h";
+ }
+
+ my $foo = "1234567890";
+
+ ok syswrite($io, $foo, length($foo)) == length($foo) ;
+ if ( $[ < 5.6 )
+ { is $io->syswrite($foo, length $foo), length $foo }
+ else
+ { is $io->syswrite($foo), length $foo }
+ ok $io->syswrite($foo, length($foo)) == length $foo;
+ ok $io->write($foo, length($foo), 5) == 5;
+ ok $io->write("xxx\n", 100, -1) == 1;
+
+ for (1..3) {
+ printf $io "i(%d)", $_;
+ $io->printf("[%d]\n", $_);
+ }
+ select $io;
+ print "\n";
+ select STDOUT;
+
+ close $io ;
+
+ ok eof($io);
+ ok $io->eof();
+
+ is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
+ ("1234567890" x 3) . "67890\n" .
+ "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
+
+
+ }
+
+ {
+ # Read
+ my $str = <<EOT;
+This is an example
+of a paragraph
+
+
+and a single line.
+
+EOT
+
+ my $lex = new LexFile my $name ;
+
+ my $iow = new $CompressClass $name ;
+ print $iow $str ;
+ close $iow;
+
+ my @tmp;
+ my $buf;
+ {
+ my $io = new $UncompressClass $name ;
+
+ ok ! $io->eof;
+ ok ! eof $io;
+ is $io->tell(), 0 ;
+ is tell($io), 0 ;
+ my @lines = <$io>;
+ is @lines, 6
+ or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
+ is $lines[1], "of a paragraph\n" ;
+ is join('', @lines), $str ;
+ is $., 6;
+ #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ;
+ is $io->tell(), length($str) ;
+ is tell($io), length($str) ;
+
+ ok $io->eof;
+ ok eof $io;
+
+ ok ! ( defined($io->getline) ||
+ (@tmp = $io->getlines) ||
+ defined(<$io>) ||
+ defined($io->getc) ||
+ read($io, $buf, 100) != 0) ;
+ }
+
+
+ {
+ local $/; # slurp mode
+ my $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my @lines = $io->getlines;
+ ok $io->eof;
+ ok @lines == 1 && $lines[0] eq $str;
+
+ $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my $line = <$io>;
+ ok $line eq $str;
+ ok $io->eof;
+ }
+
+ {
+ local $/ = ""; # paragraph mode
+ my $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my @lines = <$io>;
+ ok $io->eof;
+ ok @lines == 2
+ or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
+ ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
+ or print "# $lines[0]\n";
+ ok $lines[1] eq "and a single line.\n\n";
+ }
+
+ {
+ local $/ = "is";
+ my $io = $UncompressClass->new($name);
+ my @lines = ();
+ my $no = 0;
+ my $err = 0;
+ ok ! $io->eof;
+ while (<$io>) {
+ push(@lines, $_);
+ $err++ if $. != ++$no;
+ }
+
+ ok $err == 0 ;
+ ok $io->eof;
+
+ ok @lines == 3
+ or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
+ ok join("-", @lines) eq
+ "This- is- an example\n" .
+ "of a paragraph\n\n\n" .
+ "and a single line.\n\n";
+ }
+
+
+ # Test read
+
+ {
+ my $io = $UncompressClass->new($name);
+
+ ok $io, "opened ok" ;
+
+ #eval { read($io, $buf, -1); } ;
+ #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ;
+
+ #eval { read($io, 1) } ;
+ #like $@, mkErr("buffer parameter is read-only");
+
+ is read($io, $buf, 0), 0, "Requested 0 bytes" ;
+
+ ok read($io, $buf, 3) == 3 ;
+ ok $buf eq "Thi";
+
+ ok sysread($io, $buf, 3, 2) == 3 ;
+ ok $buf eq "Ths i"
+ or print "# [$buf]\n" ;;
+ ok ! $io->eof;
+
+ # $io->seek(-4, 2);
+ #
+ # ok ! $io->eof;
+ #
+ # ok read($io, $buf, 20) == 4 ;
+ # ok $buf eq "e.\n\n";
+ #
+ # ok read($io, $buf, 20) == 0 ;
+ # ok $buf eq "";
+ #
+ # ok ! $io->eof;
+ }
+
+ }
+
+
+
+ {
+ title "seek tests" ;
+
+ my $lex = new LexFile my $name ;
+
+ my $first = "beginning" ;
+ my $last = "the end" ;
+ my $iow = new $CompressClass $name ;
+ print $iow $first ;
+ ok seek $iow, 10, SEEK_CUR ;
+ is tell($iow), length($first)+10;
+ ok $iow->seek(0, SEEK_CUR) ;
+ is tell($iow), length($first)+10;
+ print $iow $last ;
+ close $iow;
+
+ my $io = $UncompressClass->new($name);
+ ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ;
+
+ $io = $UncompressClass->new($name);
+ ok seek $io, length($first)+10, SEEK_CUR ;
+ ok ! $io->eof;
+ is tell($io), length($first)+10;
+ ok seek $io, 0, SEEK_CUR ;
+ is tell($io), length($first)+10;
+ my $buff ;
+ ok read $io, $buff, 100 ;
+ ok $buff eq $last ;
+ ok $io->eof;
+ }
+
+ if (! $BadPerl)
+ {
+ # seek error cases
+ my $b ;
+ my $a = new $CompressClass(\$b) ;
+
+ ok ! $a->error() ;
+ eval { seek($a, -1, 10) ; };
+ like $@, mkErr("seek: unknown value, 10, for whence parameter");
+
+ eval { seek($a, -1, SEEK_END) ; };
+ like $@, mkErr("cannot seek backwards");
+
+ print $a "fred";
+ close $a ;
+
+
+ my $u = new $UncompressClass(\$b) ;
+
+ eval { seek($u, -1, 10) ; };
+ like $@, mkErr("seek: unknown value, 10, for whence parameter");
+
+ eval { seek($u, -1, SEEK_END) ; };
+ like $@, mkErr("seek: SEEK_END not allowed");
+
+ eval { seek($u, -1, SEEK_CUR) ; };
+ like $@, mkErr("cannot seek backwards");
+ }
+
+ {
+ title 'fileno' ;
+
+ my $lex = new LexFile my $name ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ {
+ my $fh ;
+ ok $fh = new IO::File ">$name" ;
+ my $x ;
+ ok $x = new $CompressClass $fh ;
+
+ ok $x->fileno() == fileno($fh) ;
+ ok $x->fileno() == fileno($x) ;
+ ok $x->write($hello) ;
+ ok $x->close ;
+ $fh->close() ;
+ }
+
+ my $uncomp;
+ {
+ my $x ;
+ ok my $fh1 = new IO::File "<$name" ;
+ ok $x = new $UncompressClass $fh1, -Append => 1 ;
+ ok $x->fileno() == fileno $fh1 ;
+ ok $x->fileno() == fileno $x ;
+
+ 1 while $x->read($uncomp) > 0 ;
+
+ ok $x->close ;
+ }
+
+ ok $hello eq $uncomp ;
+ }
+ }
+}
+
+1;
--- /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 => 944 + $extra ;
+
+ use_ok('IO::Uncompress::AnyInflate', qw(anyinflate $AnyInflateError)) ;
+
+}
+
+sub run
+{
+
+ my $CompressClass = identify();
+ my $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+ my $TopFuncName = getTopFuncName($CompressClass);
+
+
+
+ foreach my $bit ($CompressClass, $UncompressClass,
+ 'IO::Uncompress::AnyInflate',
+ )
+ {
+ my $Error = getErrorRef($bit);
+ my $Func = getTopFuncRef($bit);
+ my $TopType = getTopFuncName($bit);
+
+ title "Testing $TopType Error Cases";
+
+ my $a;
+ my $x ;
+
+ eval { $a = $Func->(\$a => \$x, Fred => 1) ;} ;
+ like $@, mkErr("^$TopType: unknown key value\\(s\\) Fred"), ' Illegal Parameters';
+
+ eval { $a = $Func->() ;} ;
+ like $@, mkErr("^$TopType: expected at least 1 parameters"), ' No Parameters';
+
+ eval { $a = $Func->(\$x, \1) ;} ;
+ like $$Error, "/^$TopType: output buffer is read-only/", ' Output is read-only' ;
+
+ my $in ;
+ eval { $a = $Func->($in, \$x) ;} ;
+ like $@, mkErr("^$TopType: input filename is undef or null string"),
+ ' Input filename undef' ;
+
+ $in = '';
+ eval { $a = $Func->($in, \$x) ;} ;
+ like $@, mkErr("^$TopType: input filename is undef or null string"),
+ ' Input filename empty' ;
+
+ {
+ my $lex1 = new LexFile my $in ;
+ writeFile($in, "abc");
+ my $out = $in ;
+ eval { $a = $Func->($in, $out) ;} ;
+ like $@, mkErr("^$TopType: input and output filename are identical"),
+ ' Input and Output filename are the same';
+ }
+
+ eval { $a = $Func->(\$in, \$in) ;} ;
+ like $@, mkErr("^$TopType: input and output buffer are identical"),
+ ' Input and Output buffer are the same';
+
+ my $lex = new LexFile my $out_file ;
+ open OUT, ">$out_file" ;
+ eval { $a = $Func->(\*OUT, \*OUT) ;} ;
+ like $@, mkErr("^$TopType: input and output handle are identical"),
+ ' Input and Output handle are the same';
+
+ close OUT;
+ is -s $out_file, 0, " File zero length" ;
+ {
+ my %x = () ;
+ my $object = bless \%x, "someClass" ;
+
+ # Buffer not a scalar reference
+ #eval { $a = $Func->(\$x, \%x) ;} ;
+ eval { $a = $Func->(\$x, $object) ;} ;
+ like $@, mkErr("^$TopType: illegal output parameter"),
+ ' Bad Output Param';
+
+ # Buffer not a scalar reference
+ eval { $a = $Func->(\$x, \%x) ;} ;
+ like $@, mkErr("^$TopType: illegal output parameter"),
+ ' Bad Output Param';
+
+
+ eval { $a = $Func->(\%x, \$x) ;} ;
+ like $@, mkErr("^$TopType: illegal input parameter"),
+ ' Bad Input Param';
+
+ #eval { $a = $Func->(\%x, \$x) ;} ;
+ eval { $a = $Func->($object, \$x) ;} ;
+ like $@, mkErr("^$TopType: illegal input parameter"),
+ ' Bad Input Param';
+ }
+
+ my $filename = 'abc.def';
+ ok ! -e $filename, " input file '$filename' does not exist";
+ $a = $Func->($filename, \$x) ;
+ is $a, undef, " $TopType returned undef";
+ like $$Error, "/^input file '$filename' does not exist\$/", " input File '$filename' does not exist";
+
+ $filename = '/tmp/abd/abc.def';
+ ok ! -e $filename, " output File '$filename' does not exist";
+ $a = $Func->(\$x, $filename) ;
+ is $a, undef, " $TopType returned undef";
+ like $$Error, ("/^(cannot open file '$filename'|input file '$filename' does not exist):/"), " output File '$filename' does not exist";
+
+ eval { $a = $Func->(\$x, '<abc>') } ;
+ like $$Error, "/Need input fileglob for outout fileglob/",
+ ' Output fileglob with no input fileglob';
+ is $a, undef, " $TopType returned undef";
+
+ $a = $Func->('<abc)>', '<abc>') ;
+ is $a, undef, " $TopType returned undef";
+ like $$Error, "/Unmatched \\) in input fileglob/",
+ " Unmatched ) in input fileglob";
+ }
+
+ foreach my $bit ($UncompressClass,
+ 'IO::Uncompress::AnyInflate',
+ )
+ {
+ my $Error = getErrorRef($bit);
+ my $Func = getTopFuncRef($bit);
+ my $TopType = getTopFuncName($bit);
+
+ my $data = "mary had a little lamb" ;
+ my $keep = $data ;
+
+ for my $trans ( 0, 1)
+ {
+ title "Non-compressed data with $TopType, Transparent => $trans ";
+ my $a;
+ my $x ;
+ my $out = '' ;
+
+ $a = $Func->(\$data, \$out, Transparent => $trans) ;
+
+ is $data, $keep, " Input buffer not changed" ;
+
+ if ($trans)
+ {
+ ok $a, " $TopType returned true" ;
+ is $out, $data, " got expected output" ;
+ ok ! $$Error, " no error [$$Error]" ;
+ }
+ else
+ {
+ ok ! $a, " $TopType returned false" ;
+ #like $$Error, '/xxx/', " error" ;
+ ok $$Error, " error is '$$Error'" ;
+ }
+ }
+ }
+
+ foreach my $bit ($CompressClass
+ )
+ {
+ my $Error = getErrorRef($bit);
+ my $Func = getTopFuncRef($bit);
+ my $TopType = getTopFuncName($bit);
+ my $TopTypeInverse = getInverse($bit);
+ my $FuncInverse = getTopFuncRef($TopTypeInverse);
+ my $ErrorInverse = getErrorRef($TopTypeInverse);
+
+ title "$TopTypeInverse - corrupt data";
+
+ my $data = "abcd" x 100 ;
+ my $out;
+
+ ok $Func->(\$data, \$out), " $TopType ok";
+
+ # corrupt the compressed data
+ #substr($out, -10, 10) = "x" x 10 ;
+ substr($out, int(length($out)/3), 10) = 'abcdeabcde';
+
+ my $result;
+ ok ! $FuncInverse->(\$out => \$result, Transparent => 0), " $TopTypeInverse ok";
+ ok $$ErrorInverse, " Got error '$$ErrorInverse'" ;
+
+ #is $result, $data, " data ok";
+
+ ok ! anyinflate(\$out => \$result, Transparent => 0), " anyinflate ok";
+ ok $AnyInflateError, " Got error '$AnyInflateError'" ;
+ }
+
+
+ foreach my $bit ($CompressClass
+ )
+ {
+ my $Error = getErrorRef($bit);
+ my $Func = getTopFuncRef($bit);
+ my $TopType = getTopFuncName($bit);
+ my $TopTypeInverse = getInverse($bit);
+ my $FuncInverse = getTopFuncRef($TopTypeInverse);
+
+ for my $append ( 1, 0 )
+ {
+ my $already = '';
+ $already = 'abcde' if $append ;
+
+ for my $buffer ( undef, '', "abcde" )
+ {
+
+ my $disp_content = defined $buffer ? $buffer : '<undef>' ;
+
+ my $keep = $buffer;
+ my $out_file = "abcde.out";
+ my $in_file = "abcde.in";
+
+ {
+ title "$TopType - From Buff to Buff content '$disp_content' Append $append" ;
+
+ my $output = $already;
+ ok &$Func(\$buffer, \$output, Append => $append), ' Compressed ok' ;
+
+ is $keep, $buffer, " Input buffer not changed" ;
+ my $got = anyUncompress(\$output, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $got, $buffer, " Uncompressed matches original";
+
+ }
+
+ {
+ title "$TopType - From Buff to Array Ref content '$disp_content' Append $append" ;
+
+ my @output = ('first') ;
+ ok &$Func(\$buffer, \@output, Append => $append), ' Compressed ok' ;
+
+ is $output[0], 'first', " Array[0] unchanged";
+ is $keep, $buffer, " Input buffer not changed" ;
+ my $got = anyUncompress($output[1]);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $got, $buffer, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Array Ref to Array Ref content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile my $in_file ;
+ writeFile($in_file, $buffer);
+ my @output = ('first') ;
+ my @input = ($in_file);
+ ok &$Func(\@input, \@output, Append => $append), ' Compressed ok' ;
+
+ is $output[0], 'first', " Array[0] unchanged";
+ my $got = anyUncompress($output[1]);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $got, $buffer, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Buff to Filename content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile my $out_file ;
+ ok ! -e $out_file, " Output file does not exist";
+ writeFile($out_file, $already);
+
+ ok &$Func(\$buffer, $out_file, Append => $append), ' Compressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $got = anyUncompress($out_file, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $got, $buffer, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Buff to Handle content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile my $out_file ;
+
+ ok ! -e $out_file, " Output file does not exist";
+ writeFile($out_file, $already);
+ my $of = new IO::File ">>$out_file" ;
+ ok $of, " Created output filehandle" ;
+
+ ok &$Func(\$buffer, $of, AutoClose => 1, Append => $append), ' Compressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $got = anyUncompress($out_file, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $got, $buffer, " Uncompressed matches original";
+ }
+
+
+ {
+ title "$TopType - From Filename to Filename content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ writeFile($in_file, $buffer);
+
+ ok ! -e $out_file, " Output file does not exist";
+ writeFile($out_file, $already);
+
+ ok &$Func($in_file => $out_file, Append => $append), ' Compressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $got = anyUncompress($out_file, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $got, $buffer, " Uncompressed matches original";
+
+ }
+
+ {
+ title "$TopType - From Filename to Handle content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ writeFile($in_file, $buffer);
+
+ ok ! -e $out_file, " Output file does not exist";
+ writeFile($out_file, $already);
+ my $out = new IO::File ">>$out_file" ;
+
+ ok &$Func($in_file, $out, AutoClose => 1, Append => $append), ' Compressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $got = anyUncompress($out_file, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $got, $buffer, " Uncompressed matches original";
+
+ }
+
+ {
+ title "$TopType - From Filename to Buffer content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ writeFile($in_file, $buffer);
+
+ my $out = $already;
+
+ ok &$Func($in_file => \$out, Append => $append), ' Compressed ok' ;
+
+ my $got = anyUncompress(\$out, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $got, $buffer, " Uncompressed matches original";
+
+ }
+
+ {
+ title "$TopType - From Handle to Filename content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ writeFile($in_file, $buffer);
+ my $in = new IO::File "<$in_file" ;
+
+ ok ! -e $out_file, " Output file does not exist";
+ writeFile($out_file, $already);
+
+ ok &$Func($in, $out_file, Append => $append), ' Compressed ok'
+ or diag "error is $$Error" ;
+
+ ok -e $out_file, " Created output file";
+ my $got = anyUncompress($out_file, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $buffer, $got, " Uncompressed matches original";
+
+ }
+
+ {
+ title "$TopType - From Handle to Handle content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ writeFile($in_file, $buffer);
+ my $in = new IO::File "<$in_file" ;
+
+ ok ! -e $out_file, " Output file does not exist";
+ writeFile($out_file, $already);
+ my $out = new IO::File ">>$out_file" ;
+
+ ok &$Func($in, $out, AutoClose => 1, Append => $append), ' Compressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $got = anyUncompress($out_file, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $buffer, $got, " Uncompressed matches original";
+
+ }
+
+ {
+ title "$TopType - From Handle to Buffer content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ writeFile($in_file, $buffer);
+ my $in = new IO::File "<$in_file" ;
+
+ my $out = $already ;
+
+ ok &$Func($in, \$out, Append => $append), ' Compressed ok' ;
+
+ my $got = anyUncompress(\$out, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $buffer, $got, " Uncompressed matches original";
+
+ }
+
+ {
+ title "$TopType - From stdin (via '-') to Buffer content '$disp_content' Append $append" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ writeFile($in_file, $buffer);
+
+ open(SAVEIN, "<&STDIN");
+ my $dummy = fileno SAVEIN ;
+ ok open(STDIN, "<$in_file"), " redirect STDIN";
+
+ my $out = $already;
+
+ ok &$Func('-', \$out, Append => $append), ' Compressed ok'
+ or diag $$Error ;
+
+ open(STDIN, "<&SAVEIN");
+
+ my $got = anyUncompress(\$out, $already);
+ $got = undef if ! defined $buffer && $got eq '' ;
+ is $buffer, $got, " Uncompressed matches original";
+
+ }
+
+ }
+ }
+ }
+
+ foreach my $bit ($CompressClass)
+ {
+ my $Error = getErrorRef($bit);
+ my $Func = getTopFuncRef($bit);
+ my $TopType = getTopFuncName($bit);
+
+ my $TopTypeInverse = getInverse($bit);
+ my $FuncInverse = getTopFuncRef($TopTypeInverse);
+
+ my $lex = new LexFile(my $file1, my $file2) ;
+
+ writeFile($file1, "data1");
+ writeFile($file2, "data2");
+ my $of = new IO::File "<$file1" ;
+ ok $of, " Created output filehandle" ;
+
+ #my @input = ( undef, "", $file2, \undef, \'', \"abcde", $of) ;
+ #my @expected = ("", "", $file2, "", "", "abcde", "data1");
+ #my @uexpected = ("", "", "data2", "", "", "abcde", "data1");
+ #my @input = ( $file2, \"abcde", $of) ;
+ #my @expected = ( $file2, "abcde", "data1");
+ #my @uexpected = ("data2", "abcde", "data1");
+
+ my @input = ( $file1, $file2) ;
+ #my @expected = ( $file1, $file2);
+ my @expected = ("data1", "data2");
+ my @uexpected = ("data1", "data2");
+
+ my @keep = @input ;
+
+ {
+ title "$TopType - From Array Ref to Array Ref" ;
+
+ my @output = ('first') ;
+ ok &$Func(\@input, \@output, AutoClose => 0), ' Compressed ok' ;
+
+ is $output[0], 'first', " Array[0] unchanged";
+
+ is_deeply \@input, \@keep, " Input array not changed" ;
+ my @got = shift @output;
+ foreach (@output) { push @got, anyUncompress($_) }
+
+ is_deeply \@got, ['first', @expected], " Got Expected uncompressed data";
+
+ }
+
+ foreach my $ms (1, 0)
+ {
+ {
+ title "$TopType - From Array Ref to Buffer, MultiStream $ms" ;
+
+ # rewind the filehandle
+ $of->open("<$file1") ;
+
+ my $output ;
+ ok &$Func(\@input, \$output, MultiStream => $ms, AutoClose => 0), ' Compressed ok'
+ or diag $$Error;
+
+ my $got = anyUncompress([ \$output, MultiStream => $ms ]);
+
+ is $got, join('', @uexpected), " Got Expected uncompressed data";
+ my @headers = getHeaders(\$output);
+ is @headers, $ms ? @input : 1, " Header count ok";
+ }
+
+ {
+ title "$TopType - From Array Ref to Filename, MultiStream $ms" ;
+
+ my $lex = new LexFile( my $file3) ;
+
+ # rewind the filehandle
+ $of->open("<$file1") ;
+
+ my $output ;
+ ok &$Func(\@input, $file3, MultiStream => $ms, AutoClose => 0), ' Compressed ok' ;
+
+ my $got = anyUncompress([ $file3, MultiStream => $ms ]);
+
+ is $got, join('', @uexpected), " Got Expected uncompressed data";
+ my @headers = getHeaders($file3);
+ is @headers, $ms ? @input : 1, " Header count ok";
+ }
+
+ {
+ title "$TopType - From Array Ref to Filehandle, MultiStream $ms" ;
+
+ my $lex = new LexFile(my $file3) ;
+
+ my $fh3 = new IO::File ">$file3";
+
+ # rewind the filehandle
+ $of->open("<$file1") ;
+
+ my $output ;
+ ok &$Func(\@input, $fh3, MultiStream => $ms, AutoClose => 0), ' Compressed ok' ;
+
+ $fh3->close();
+
+ my $got = anyUncompress([ $file3, MultiStream => $ms ]);
+
+ is $got, join('', @uexpected), " Got Expected uncompressed data";
+ my @headers = getHeaders($file3);
+ is @headers, $ms ? @input : 1, " Header count ok";
+ }
+ }
+ }
+
+# foreach my $bit ($CompressClass)
+# {
+# my $Error = getErrorRef($bit);
+# my $Func = getTopFuncRef($bit);
+# my $TopType = getTopFuncName($bit);
+#
+# my $TopTypeInverse = getInverse($bit);
+# my $FuncInverse = getTopFuncRef($TopTypeInverse);
+#
+# my @inFiles = map { "in$_.tmp" } 1..4;
+# my @outFiles = map { "out$_.tmp" } 1..4;
+# my $lex = new LexFile(@inFiles, @outFiles);
+#
+# writeFile($_, "data $_") foreach @inFiles ;
+#
+# {
+# title "$TopType - Hash Ref: to filename" ;
+#
+# my $output ;
+# ok &$Func( { $inFiles[0] => $outFiles[0],
+# $inFiles[1] => $outFiles[1],
+# $inFiles[2] => $outFiles[2] } ), ' Compressed ok' ;
+#
+# foreach (0 .. 2)
+# {
+# my $got = anyUncompress($outFiles[$_]);
+# is $got, "data $inFiles[$_]", " Uncompressed $_ matches original";
+# }
+# }
+#
+# {
+# title "$TopType - Hash Ref: to buffer" ;
+#
+# my @buffer ;
+# ok &$Func( { $inFiles[0] => \$buffer[0],
+# $inFiles[1] => \$buffer[1],
+# $inFiles[2] => \$buffer[2] } ), ' Compressed ok' ;
+#
+# foreach (0 .. 2)
+# {
+# my $got = anyUncompress(\$buffer[$_]);
+# is $got, "data $inFiles[$_]", " Uncompressed $_ matches original";
+# }
+# }
+#
+# {
+# title "$TopType - Hash Ref: to undef" ;
+#
+# my @buffer ;
+# my %hash = ( $inFiles[0] => undef,
+# $inFiles[1] => undef,
+# $inFiles[2] => undef,
+# );
+#
+# ok &$Func( \%hash ), ' Compressed ok' ;
+#
+# foreach (keys %hash)
+# {
+# my $got = anyUncompress(\$hash{$_});
+# is $got, "data $_", " Uncompressed $_ matches original";
+# }
+# }
+#
+# {
+# title "$TopType - Filename to Hash Ref" ;
+#
+# my %output ;
+# ok &$Func( $inFiles[0] => \%output), ' Compressed ok' ;
+#
+# is keys %output, 1, " one pair in hash" ;
+# my ($k, $v) = each %output;
+# is $k, $inFiles[0], " key is '$inFiles[0]'";
+# my $got = anyUncompress($v);
+# is $got, "data $inFiles[0]", " Uncompressed matches original";
+# }
+#
+# {
+# title "$TopType - File Glob to Hash Ref" ;
+#
+# my %output ;
+# ok &$Func( '<in*.tmp>' => \%output), ' Compressed ok' ;
+#
+# is keys %output, 4, " four pairs in hash" ;
+# foreach my $fil (@inFiles)
+# {
+# ok exists $output{$fil}, " key '$fil' exists" ;
+# my $got = anyUncompress($output{$fil});
+# is $got, "data $fil", " Uncompressed matches original";
+# }
+# }
+#
+#
+# }
+
+# foreach my $bit ($CompressClass)
+# {
+# my $Error = getErrorRef($bit);
+# my $Func = getTopFuncRef($bit);
+# my $TopType = getTopFuncName($bit);
+#
+# my $TopTypeInverse = getInverse($bit);
+# my $FuncInverse = getTopFuncRef($TopTypeInverse);
+#
+# my @inFiles = map { "in$_.tmp" } 1..4;
+# my @outFiles = map { "out$_.tmp" } 1..4;
+# my $lex = new LexFile(@inFiles, @outFiles);
+#
+# writeFile($_, "data $_") foreach @inFiles ;
+#
+#
+#
+# # if (0)
+# # {
+# # title "$TopType - Hash Ref to Array Ref" ;
+# #
+# # my @output = ('first') ;
+# # ok &$Func( { \@input, \@output } , AutoClose => 0), ' Compressed ok' ;
+# #
+# # is $output[0], 'first', " Array[0] unchanged";
+# #
+# # is_deeply \@input, \@keep, " Input array not changed" ;
+# # my @got = shift @output;
+# # foreach (@output) { push @got, anyUncompress($_) }
+# #
+# # is_deeply \@got, ['first', @expected], " Got Expected uncompressed data";
+# #
+# # }
+# #
+# # if (0)
+# # {
+# # title "$TopType - From Array Ref to Buffer" ;
+# #
+# # # rewind the filehandle
+# # $of->open("<$file1") ;
+# #
+# # my $output ;
+# # ok &$Func(\@input, \$output, AutoClose => 0), ' Compressed ok' ;
+# #
+# # my $got = anyUncompress(\$output);
+# #
+# # is $got, join('', @expected), " Got Expected uncompressed data";
+# # }
+# #
+# # if (0)
+# # {
+# # title "$TopType - From Array Ref to Filename" ;
+# #
+# # my ($file3) = ("file3");
+# # my $lex = new LexFile($file3) ;
+# #
+# # # rewind the filehandle
+# # $of->open("<$file1") ;
+# #
+# # my $output ;
+# # ok &$Func(\@input, $file3, AutoClose => 0), ' Compressed ok' ;
+# #
+# # my $got = anyUncompress($file3);
+# #
+# # is $got, join('', @expected), " Got Expected uncompressed data";
+# # }
+# #
+# # if (0)
+# # {
+# # title "$TopType - From Array Ref to Filehandle" ;
+# #
+# # my ($file3) = ("file3");
+# # my $lex = new LexFile($file3) ;
+# #
+# # my $fh3 = new IO::File ">$file3";
+# #
+# # # rewind the filehandle
+# # $of->open("<$file1") ;
+# #
+# # my $output ;
+# # ok &$Func(\@input, $fh3, AutoClose => 0), ' Compressed ok' ;
+# #
+# # $fh3->close();
+# #
+# # my $got = anyUncompress($file3);
+# #
+# # is $got, join('', @expected), " Got Expected uncompressed data";
+# # }
+# }
+
+ foreach my $bit ($CompressClass
+ )
+ {
+ my $Error = getErrorRef($bit);
+ my $Func = getTopFuncRef($bit);
+ my $TopType = getTopFuncName($bit);
+
+ for my $files ( [qw(a1)], [qw(a1 a2 a3)] )
+ {
+
+ my $tmpDir1 = 'tmpdir1';
+ my $tmpDir2 = 'tmpdir2';
+ my $lex = new LexDir($tmpDir1, $tmpDir2) ;
+
+ mkdir $tmpDir1, 0777;
+ mkdir $tmpDir2, 0777;
+
+ ok -d $tmpDir1, " Temp Directory $tmpDir1 exists";
+ #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist";
+
+ my @files = map { "$tmpDir1/$_.tmp" } @$files ;
+ foreach (@files) { writeFile($_, "abc $_") }
+
+ my @expected = map { "abc $_" } @files ;
+ my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ;
+
+ {
+ title "$TopType - From FileGlob to FileGlob files [@$files]" ;
+
+ ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' Compressed ok'
+ or diag $$Error ;
+
+ my @copy = @expected;
+ for my $file (@outFiles)
+ {
+ is anyUncompress($file), shift @copy, " got expected from $file" ;
+ }
+
+ is @copy, 0, " got all files";
+ }
+
+ {
+ title "$TopType - From FileGlob to Array files [@$files]" ;
+
+ my @buffer = ('first') ;
+ ok &$Func("<$tmpDir1/a*.tmp>" => \@buffer), ' Compressed ok'
+ or diag $$Error ;
+
+ is shift @buffer, 'first';
+
+ my @copy = @expected;
+ for my $buffer (@buffer)
+ {
+ is anyUncompress($buffer), shift @copy, " got expected " ;
+ }
+
+ is @copy, 0, " got all files";
+ }
+
+ foreach my $ms (0, 1)
+ {
+ {
+ title "$TopType - From FileGlob to Buffer files [@$files], MS $ms" ;
+
+ my $buffer ;
+ ok &$Func("<$tmpDir1/a*.tmp>" => \$buffer,
+ MultiStream => $ms), ' Compressed ok'
+ or diag $$Error ;
+
+ #hexDump(\$buffer);
+
+ my $got = anyUncompress([ \$buffer, MultiStream => $ms ]);
+
+ is $got, join("", @expected), " got expected" ;
+ my @headers = getHeaders(\$buffer);
+ is @headers, $ms ? @files : 1, " Header count ok";
+ }
+
+ {
+ title "$TopType - From FileGlob to Filename files [@$files], MS $ms" ;
+
+ my $filename = "abcde";
+ my $lex = new LexFile($filename) ;
+
+ ok &$Func("<$tmpDir1/a*.tmp>" => $filename,
+ MultiStream => $ms), ' Compressed ok'
+ or diag $$Error ;
+
+ #hexDump(\$buffer);
+
+ my $got = anyUncompress([$filename, MultiStream => $ms]);
+
+ is $got, join("", @expected), " got expected" ;
+ my @headers = getHeaders($filename);
+ is @headers, $ms ? @files : 1, " Header count ok";
+ }
+
+ {
+ title "$TopType - From FileGlob to Filehandle files [@$files], MS $ms" ;
+
+ my $filename = "abcde";
+ my $lex = new LexFile($filename) ;
+ my $fh = new IO::File ">$filename";
+
+ ok &$Func("<$tmpDir1/a*.tmp>" => $fh,
+ MultiStream => $ms, AutoClose => 1), ' Compressed ok'
+ or diag $$Error ;
+
+ #hexDump(\$buffer);
+
+ my $got = anyUncompress([$filename, MultiStream => $ms]);
+
+ is $got, join("", @expected), " got expected" ;
+ my @headers = getHeaders($filename);
+ is @headers, $ms ? @files : 1, " Header count ok";
+ }
+ }
+ }
+
+ }
+
+ foreach my $bit ($UncompressClass,
+ 'IO::Uncompress::AnyInflate',
+ )
+ {
+ my $Error = getErrorRef($bit);
+ my $Func = getTopFuncRef($bit);
+ my $TopType = getTopFuncName($bit);
+
+ my $buffer = "abcde" ;
+ my $buffer2 = "ABCDE" ;
+ my $keep_orig = $buffer;
+
+ my $comp = compressBuffer($TopType, $buffer) ;
+ my $comp2 = compressBuffer($TopType, $buffer2) ;
+ my $keep_comp = $comp;
+
+ my $incumbent = "incumbent data" ;
+
+ for my $append (0, 1)
+ {
+ my $expected = $buffer ;
+ $expected = $incumbent . $buffer if $append ;
+
+ {
+ title "$TopType - From Buff to Buff, Append($append)" ;
+
+ my $output ;
+ $output = $incumbent if $append ;
+ ok &$Func(\$comp, \$output, Append => $append), ' Uncompressed ok' ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $output, $expected, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Buff to Array, Append($append)" ;
+
+ my @output = ('first');
+ #$output = $incumbent if $append ;
+ ok &$Func(\$comp, \@output, Append => $append), ' Uncompressed ok' ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $output[0], 'first', " Uncompressed matches original";
+ is ${ $output[1] }, $buffer, " Uncompressed matches original"
+ or diag $output[1] ;
+ is @output, 2, " only 2 elements in the array" ;
+ }
+
+ {
+ title "$TopType - From Buff to Filename, Append($append)" ;
+
+ my $lex = new LexFile(my $out_file) ;
+ if ($append)
+ { writeFile($out_file, $incumbent) }
+ else
+ { ok ! -e $out_file, " Output file does not exist" }
+
+ ok &$Func(\$comp, $out_file, Append => $append), ' Uncompressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $content = readFile($out_file) ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $content, $expected, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Buff to Handle, Append($append)" ;
+
+ my $lex = new LexFile(my $out_file) ;
+ my $of ;
+ if ($append) {
+ writeFile($out_file, $incumbent) ;
+ $of = new IO::File "+< $out_file" ;
+ }
+ else {
+ ok ! -e $out_file, " Output file does not exist" ;
+ $of = new IO::File "> $out_file" ;
+ }
+ isa_ok $of, 'IO::File', ' $of' ;
+
+ ok &$Func(\$comp, $of, Append => $append, AutoClose => 1), ' Uncompressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $content = readFile($out_file) ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $content, $expected, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Filename to Filename, Append($append)" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ if ($append)
+ { writeFile($out_file, $incumbent) }
+ else
+ { ok ! -e $out_file, " Output file does not exist" }
+
+ writeFile($in_file, $comp);
+
+ ok &$Func($in_file, $out_file, Append => $append), ' Uncompressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $content = readFile($out_file) ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $content, $expected, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Filename to Handle, Append($append)" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ my $out ;
+ if ($append) {
+ writeFile($out_file, $incumbent) ;
+ $out = new IO::File "+< $out_file" ;
+ }
+ else {
+ ok ! -e $out_file, " Output file does not exist" ;
+ $out = new IO::File "> $out_file" ;
+ }
+ isa_ok $out, 'IO::File', ' $out' ;
+
+ writeFile($in_file, $comp);
+
+ ok &$Func($in_file, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $content = readFile($out_file) ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $content, $expected, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Filename to Buffer, Append($append)" ;
+
+ my $lex = new LexFile(my $in_file) ;
+ writeFile($in_file, $comp);
+
+ my $output ;
+ $output = $incumbent if $append ;
+
+ ok &$Func($in_file, \$output, Append => $append), ' Uncompressed ok' ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $output, $expected, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Handle to Filename, Append($append)" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ if ($append)
+ { writeFile($out_file, $incumbent) }
+ else
+ { ok ! -e $out_file, " Output file does not exist" }
+
+ writeFile($in_file, $comp);
+ my $in = new IO::File "<$in_file" ;
+
+ ok &$Func($in, $out_file, Append => $append), ' Uncompressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $content = readFile($out_file) ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $content, $expected, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Handle to Handle, Append($append)" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ my $out ;
+ if ($append) {
+ writeFile($out_file, $incumbent) ;
+ $out = new IO::File "+< $out_file" ;
+ }
+ else {
+ ok ! -e $out_file, " Output file does not exist" ;
+ $out = new IO::File "> $out_file" ;
+ }
+ isa_ok $out, 'IO::File', ' $out' ;
+
+ writeFile($in_file, $comp);
+ my $in = new IO::File "<$in_file" ;
+
+ ok &$Func($in, $out, Append => $append, AutoClose => 1), ' Uncompressed ok' ;
+
+ ok -e $out_file, " Created output file";
+ my $content = readFile($out_file) ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $content, $expected, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From Filename to Buffer, Append($append)" ;
+
+ my $lex = new LexFile(my $in_file) ;
+ writeFile($in_file, $comp);
+ my $in = new IO::File "<$in_file" ;
+
+ my $output ;
+ $output = $incumbent if $append ;
+
+ ok &$Func($in, \$output, Append => $append), ' Uncompressed ok' ;
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $output, $expected, " Uncompressed matches original";
+ }
+
+ {
+ title "$TopType - From stdin (via '-') to Buffer content, Append($append) " ;
+
+ my $lex = new LexFile(my $in_file) ;
+ writeFile($in_file, $comp);
+
+ open(SAVEIN, "<&STDIN");
+ my $dummy = fileno SAVEIN ;
+ ok open(STDIN, "<$in_file"), " redirect STDIN";
+
+ my $output ;
+ $output = $incumbent if $append ;
+
+ ok &$Func('-', \$output, Append => $append), ' Uncompressed ok'
+ or diag $$Error ;
+
+ open(STDIN, "<&SAVEIN");
+
+ is $keep_comp, $comp, " Input buffer not changed" ;
+ is $output, $expected, " Uncompressed matches original";
+ }
+ }
+
+ {
+ title "$TopType - From Handle to Buffer, InputLength" ;
+
+ my $lex = new LexFile(my $in_file, my $out_file) ;
+ my $out ;
+
+ my $expected = $buffer ;
+ my $appended = 'appended';
+ my $len_appended = length $appended;
+ writeFile($in_file, $comp . $appended . $comp . $appended) ;
+ my $in = new IO::File "<$in_file" ;
+
+ ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ;
+
+ is $out, $expected, " Uncompressed matches original";
+
+ my $buff;
+ is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok";
+ is $buff, $appended, " Appended data ok";
+
+ $out = '';
+ ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp), ' Uncompressed ok' ;
+
+ is $out, $expected, " Uncompressed matches original";
+
+ $buff = '';
+ is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok";
+ is $buff, $appended, " Appended data ok";
+ }
+
+ for my $stdin ('-', *STDIN) # , \*STDIN)
+ {
+ title "$TopType - From stdin (via $stdin) to Buffer content, InputLength" ;
+
+ my $lex = new LexFile my $in_file ;
+ my $expected = $buffer ;
+ my $appended = 'appended';
+ my $len_appended = length $appended;
+ writeFile($in_file, $comp . $appended ) ;
+
+ open(SAVEIN, "<&STDIN");
+ my $dummy = fileno SAVEIN ;
+ ok open(STDIN, "<$in_file"), " redirect STDIN";
+
+ my $output ;
+
+ ok &$Func($stdin, \$output, Transparent => 0, InputLength => length $comp), ' Uncompressed ok'
+ or diag $$Error ;
+
+ my $buff ;
+ is read(STDIN, $buff, $len_appended), $len_appended, " Length of Appended data ok";
+
+ is $output, $expected, " Uncompressed matches original";
+ is $buff, $appended, " Appended data ok";
+
+ open(STDIN, "<&SAVEIN");
+ }
+ }
+
+ foreach my $bit ($UncompressClass,
+ 'IO::Uncompress::AnyInflate',
+ )
+ {
+ # TODO -- Add Append mode tests
+
+ my $Error = getErrorRef($bit);
+ my $Func = getTopFuncRef($bit);
+ my $TopType = getTopFuncName($bit);
+
+ my $buffer = "abcde" ;
+ my $keep_orig = $buffer;
+
+
+ my $null = compressBuffer($TopType, "") ;
+ my $undef = compressBuffer($TopType, undef) ;
+ my $comp = compressBuffer($TopType, $buffer) ;
+ my $keep_comp = $comp;
+
+ my $incumbent = "incumbent data" ;
+
+ my $lex = new LexFile(my $file1, my $file2) ;
+
+ writeFile($file1, compressBuffer($TopType,"data1"));
+ writeFile($file2, compressBuffer($TopType,"data2"));
+
+ my $of = new IO::File "<$file1" ;
+ ok $of, " Created output filehandle" ;
+
+ #my @input = ($file2, \$undef, \$null, \$comp, $of) ;
+ #my @expected = ('data2', '', '', 'abcde', 'data1');
+ my @input = ($file1, $file2);
+ my @expected = ('data1', 'data2');
+
+ my @keep = @input ;
+
+ {
+ title "$TopType - From ArrayRef to Buffer" ;
+
+ my $output ;
+ ok &$Func(\@input, \$output, AutoClose => 0), ' UnCompressed ok' ;
+
+ is $output, join('', @expected)
+ }
+
+ {
+ title "$TopType - From ArrayRef to Filename" ;
+
+ my $lex = new LexFile my $output;
+ $of->open("<$file1") ;
+
+ ok &$Func(\@input, $output, AutoClose => 0), ' UnCompressed ok' ;
+
+ is readFile($output), join('', @expected)
+ }
+
+ {
+ title "$TopType - From ArrayRef to Filehandle" ;
+
+ my $lex = new LexFile my $output;
+ my $fh = new IO::File ">$output" ;
+ $of->open("<$file1") ;
+
+ ok &$Func(\@input, $fh, AutoClose => 0), ' UnCompressed ok' ;
+ $fh->close;
+
+ is readFile($output), join('', @expected)
+ }
+
+ {
+ title "$TopType - From Array Ref to Array Ref" ;
+
+ my @output = (\'first') ;
+ $of->open("<$file1") ;
+ ok &$Func(\@input, \@output, AutoClose => 0), ' UnCompressed ok' ;
+
+ is_deeply \@input, \@keep, " Input array not changed" ;
+ is_deeply [map { defined $$_ ? $$_ : "" } @output],
+ ['first', @expected],
+ " Got Expected uncompressed data";
+
+ }
+ }
+
+ foreach my $bit ($UncompressClass,
+ 'IO::Uncompress::AnyInflate',
+ )
+ {
+ # TODO -- Add Append mode tests
+
+ my $Error = getErrorRef($bit);
+ my $Func = getTopFuncRef($bit);
+ my $TopType = getTopFuncName($bit);
+
+ my $tmpDir1 = 'tmpdir1';
+ my $tmpDir2 = 'tmpdir2';
+ my $lex = new LexDir($tmpDir1, $tmpDir2) ;
+
+ mkdir $tmpDir1, 0777;
+ mkdir $tmpDir2, 0777;
+
+ ok -d $tmpDir1, " Temp Directory $tmpDir1 exists";
+ #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist";
+
+ my @files = map { "$tmpDir1/$_.tmp" } qw( a1 a2 a3) ;
+ foreach (@files) { writeFile($_, compressBuffer($TopType, "abc $_")) }
+
+ my @expected = map { "abc $_" } @files ;
+ my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ;
+
+ {
+ title "$TopType - From FileGlob to FileGlob" ;
+
+ ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' UnCompressed ok'
+ or diag $$Error ;
+
+ my @copy = @expected;
+ for my $file (@outFiles)
+ {
+ is readFile($file), shift @copy, " got expected from $file" ;
+ }
+
+ is @copy, 0, " got all files";
+ }
+
+ {
+ title "$TopType - From FileGlob to Arrayref" ;
+
+ my @output = (\'first');
+ ok &$Func("<$tmpDir1/a*.tmp>" => \@output), ' UnCompressed ok'
+ or diag $$Error ;
+
+ my @copy = ('first', @expected);
+ for my $data (@output)
+ {
+ is $$data, shift @copy, " got expected data" ;
+ }
+
+ is @copy, 0, " got all files";
+ }
+
+ {
+ title "$TopType - From FileGlob to Buffer" ;
+
+ my $output ;
+ ok &$Func("<$tmpDir1/a*.tmp>" => \$output), ' UnCompressed ok'
+ or diag $$Error ;
+
+ is $output, join('', @expected), " got expected uncompressed data";
+ }
+
+ {
+ title "$TopType - From FileGlob to Filename" ;
+
+ my $lex = new LexFile my $output ;
+ ok ! -e $output, " $output does not exist" ;
+ ok &$Func("<$tmpDir1/a*.tmp>" => $output), ' UnCompressed ok'
+ or diag $$Error ;
+
+ ok -e $output, " $output does exist" ;
+ is readFile($output), join('', @expected), " got expected uncompressed data";
+ }
+
+ {
+ title "$TopType - From FileGlob to Filehandle" ;
+
+ my $output = 'abc' ;
+ my $lex = new LexFile $output ;
+ my $fh = new IO::File ">$output" ;
+ ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1), ' UnCompressed ok'
+ or diag $$Error ;
+
+ ok -e $output, " $output does exist" ;
+ is readFile($output), join('', @expected), " got expected uncompressed data";
+ }
+
+ }
+
+ foreach my $TopType ($CompressClass
+ # TODO -- add the inflate classes
+ )
+ {
+ my $Error = getErrorRef($TopType);
+ my $Func = getTopFuncRef($TopType);
+ my $Name = getTopFuncName($TopType);
+
+ title "More write tests" ;
+
+ my $lex = new LexFile(my $file1, my $file2, my $file3) ;
+
+ writeFile($file1, "F1");
+ writeFile($file2, "F2");
+ writeFile($file3, "F3");
+
+# my @data = (
+# [ '[\"ab", \"cd"]', "abcd" ],
+#
+# [ '[\"a", $fh1, \"bc"]', "aF1bc"],
+# ) ;
+#
+#
+# foreach my $data (@data)
+# {
+# my ($send, $get) = @$data ;
+#
+# my $fh1 = new IO::File "< $file1" ;
+# my $fh2 = new IO::File "< $file2" ;
+# my $fh3 = new IO::File "< $file3" ;
+#
+# title "$send";
+# my ($copy);
+# eval "\$copy = $send";
+# my $Answer ;
+# ok &$Func($copy, \$Answer), " $Name ok";
+#
+# my $got = anyUncompress(\$Answer);
+# is $got, $get, " got expected output" ;
+# ok ! $$Error, " no error"
+# or diag "Error is $$Error";
+#
+# }
+
+ title "Array Input Error tests" ;
+
+ my @data = (
+ [ '[]', "empty array reference"],
+ [ '[[]]', "unknown input parameter"],
+ [ '[[[]]]', "unknown input parameter"],
+ [ '[[\"ab"], [\"cd"]]', "unknown input parameter"],
+ [ '[\""]', "not a filename"],
+ [ '[\undef]', "not a filename"],
+ [ '[\"abcd"]', "not a filename"],
+ [ '[\&xx]', "unknown input parameter"],
+ [ '[$fh2]', "not a filename"],
+ ) ;
+
+
+ foreach my $data (@data)
+ {
+ my ($send, $get) = @$data ;
+
+ my $fh1 = new IO::File "< $file1" ;
+ my $fh2 = new IO::File "< $file2" ;
+ my $fh3 = new IO::File "< $file3" ;
+
+ title "$send";
+ my($copy);
+ eval "\$copy = $send";
+ my $Answer ;
+ my $a ;
+ eval { $a = &$Func($copy, \$Answer) };
+ ok ! $a, " $Name fails";
+
+ is $$Error, $get, " got error message";
+
+ }
+
+ @data = (
+ '[""]',
+ '[undef]',
+ ) ;
+
+
+ foreach my $send (@data)
+ {
+ title "$send";
+ my($copy);
+ eval "\$copy = $send";
+ my $Answer ;
+ eval { &$Func($copy, \$Answer) } ;
+ like $@, mkErr("^$TopFuncName: input filename is undef or null string"),
+ " got error message";
+
+ }
+ }
+
+}
+
+# TODO add more error cases
+
+1;
--- /dev/null
+
+use lib 't';
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+our ($extra);
+
+BEGIN {
+ # use Test::NoWarnings, if available
+ $extra = 0 ;
+ $extra = 1
+ if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
+
+}
+
+sub run
+{
+
+ my $CompressClass = identify();
+ my $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+some more stuff on this line
+ad finally...
+EOM
+
+ print "#\n# Testing $UncompressClass\n#\n";
+
+ my $compressed = mkComplete($CompressClass, $hello);
+ my $cc = $compressed ;
+
+ plan tests => (length($compressed) * 6 * 7) + 1 + $extra ;
+
+ is anyUncompress(\$cc), $hello ;
+
+ for my $blocksize (1, 2, 13)
+ {
+ for my $i (0 .. length($compressed) - 1)
+ {
+ for my $useBuf (0 .. 1)
+ {
+ print "#\n# BlockSize $blocksize, Length $i, Buffer $useBuf\n#\n" ;
+ my $lex = new LexFile my $name ;
+
+ my $prime = substr($compressed, 0, $i);
+ my $rest = substr($compressed, $i);
+
+ my $start ;
+ if ($useBuf) {
+ $start = \$rest ;
+ }
+ else {
+ $start = $name ;
+ writeFile($name, $rest);
+ }
+
+ #my $gz = new $UncompressClass $name,
+ my $gz = new $UncompressClass $start,
+ -Append => 1,
+ -BlockSize => $blocksize,
+ -Prime => $prime,
+ -Transparent => 0
+ ;
+ ok $gz;
+ ok ! $gz->error() ;
+ my $un ;
+ my $status = 1 ;
+ $status = $gz->read($un) while $status > 0 ;
+ is $status, 0 ;
+ ok ! $gz->error()
+ or print "Error is '" . $gz->error() . "'\n";
+ is $un, $hello ;
+ ok $gz->eof() ;
+ ok $gz->close() ;
+ }
+ }
+ }
+}
+
+1;
--- /dev/null
+
+use lib 't';
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+our ($BadPerl, $UncompressClass);
+
+BEGIN
+{
+ plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" )
+ if $] < 5.005 ;
+
+ # use Test::NoWarnings, if available
+ my $extra = 0 ;
+ $extra = 1
+ if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
+
+ my $tests ;
+ $BadPerl = ($] >= 5.006 and $] <= 5.008) ;
+
+ if ($BadPerl) {
+ $tests = 242 ;
+ }
+ else {
+ $tests = 250 ;
+ }
+
+ plan tests => $tests + $extra ;
+
+ use_ok('Compress::Zlib', 2) ;
+
+}
+
+
+use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+
+
+
+sub myGZreadFile
+{
+ my $filename = shift ;
+ my $init = shift ;
+
+
+ my $fil = new $UncompressClass $filename,
+ -Strict => 1,
+ -Append => 1
+ ;
+
+ my $data ;
+ $data = $init if defined $init ;
+ 1 while $fil->read($data) > 0;
+
+ $fil->close ;
+ return $data ;
+}
+
+sub run
+{
+
+ my $CompressClass = identify();
+ $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+ {
+ next if $BadPerl ;
+
+
+ title "Testing $CompressClass";
+
+
+ my $x ;
+ my $gz = new $CompressClass(\$x);
+
+ my $buff ;
+
+ eval { getc($gz) } ;
+ like $@, mkErr("^getc Not Available: File opened only for output");
+
+ eval { read($gz, $buff, 1) } ;
+ like $@, mkErr("^read Not Available: File opened only for output");
+
+ eval { <$gz> } ;
+ like $@, mkErr("^readline Not Available: File opened only for output");
+
+ }
+
+ {
+ next if $BadPerl;
+ $UncompressClass = getInverse($CompressClass);
+
+ title "Testing $UncompressClass";
+
+ my $gc ;
+ my $guz = new $CompressClass(\$gc);
+ $guz->write("abc") ;
+ $guz->close();
+
+ my $x ;
+ my $gz = new $UncompressClass(\$gc);
+
+ my $buff ;
+
+ eval { print $gz "abc" } ;
+ like $@, mkErr("^print Not Available: File opened only for intput");
+
+ eval { printf $gz "fmt", "abc" } ;
+ like $@, mkErr("^printf Not Available: File opened only for intput");
+
+ #eval { write($gz, $buff, 1) } ;
+ #like $@, mkErr("^write Not Available: File opened only for intput");
+
+ }
+
+ {
+ $UncompressClass = getInverse($CompressClass);
+
+ title "Testing $CompressClass and $UncompressClass";
+
+
+ {
+ # Write
+ # these tests come almost 100% from IO::String
+
+ my $lex = new LexFile my $name ;
+
+ my $io = $CompressClass->new($name);
+
+ is $io->tell(), 0 ;
+
+ my $heisan = "Heisan\n";
+ print $io $heisan ;
+
+ ok ! $io->eof;
+
+ is $io->tell(), length($heisan) ;
+
+ print($io "a", "b", "c");
+
+ {
+ local($\) = "\n";
+ print $io "d", "e";
+ local($,) = ",";
+ print $io "f", "g", "h";
+ }
+
+ my $foo = "1234567890";
+
+ ok syswrite($io, $foo, length($foo)) == length($foo) ;
+ if ( $[ < 5.6 )
+ { is $io->syswrite($foo, length $foo), length $foo }
+ else
+ { is $io->syswrite($foo), length $foo }
+ ok $io->syswrite($foo, length($foo)) == length $foo;
+ ok $io->write($foo, length($foo), 5) == 5;
+ ok $io->write("xxx\n", 100, -1) == 1;
+
+ for (1..3) {
+ printf $io "i(%d)", $_;
+ $io->printf("[%d]\n", $_);
+ }
+ select $io;
+ print "\n";
+ select STDOUT;
+
+ close $io ;
+
+ ok $io->eof;
+
+ is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
+ ("1234567890" x 3) . "67890\n" .
+ "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
+
+
+ }
+
+ {
+ # Read
+ my $str = <<EOT;
+This is an example
+of a paragraph
+
+
+and a single line.
+
+EOT
+
+ my $lex = new LexFile my $name ;
+
+ my $iow = new $CompressClass $name ;
+ print $iow $str ;
+ close $iow;
+
+ my @tmp;
+ my $buf;
+ {
+ my $io = new $UncompressClass $name ;
+
+ ok ! $io->eof;
+ is $io->tell(), 0 ;
+ my @lines = <$io>;
+ is @lines, 6
+ or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
+ is $lines[1], "of a paragraph\n" ;
+ is join('', @lines), $str ;
+ is $., 6;
+ is $io->tell(), length($str) ;
+
+ ok $io->eof;
+
+ ok ! ( defined($io->getline) ||
+ (@tmp = $io->getlines) ||
+ defined(<$io>) ||
+ defined($io->getc) ||
+ read($io, $buf, 100) != 0) ;
+ }
+
+
+ {
+ local $/; # slurp mode
+ my $io = $UncompressClass->new($name);
+ ok !$io->eof;
+ my @lines = $io->getlines;
+ ok $io->eof;
+ ok @lines == 1 && $lines[0] eq $str;
+
+ $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my $line = <$io>;
+ ok $line eq $str;
+ ok $io->eof;
+ }
+
+ {
+ local $/ = ""; # paragraph mode
+ my $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my @lines = <$io>;
+ ok $io->eof;
+ ok @lines == 2
+ or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
+ ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
+ or print "# $lines[0]\n";
+ ok $lines[1] eq "and a single line.\n\n";
+ }
+
+ {
+ local $/ = "is";
+ my $io = $UncompressClass->new($name);
+ my @lines = ();
+ my $no = 0;
+ my $err = 0;
+ ok ! $io->eof;
+ while (<$io>) {
+ push(@lines, $_);
+ $err++ if $. != ++$no;
+ }
+
+ ok $err == 0 ;
+ ok $io->eof;
+
+ ok @lines == 3
+ or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
+ ok join("-", @lines) eq
+ "This- is- an example\n" .
+ "of a paragraph\n\n\n" .
+ "and a single line.\n\n";
+ }
+
+
+ # Test read
+
+ {
+ my $io = $UncompressClass->new($name);
+
+
+ if (! $BadPerl) {
+ eval { read($io, $buf, -1) } ;
+ like $@, mkErr("length parameter is negative");
+ }
+
+ is read($io, $buf, 0), 0, "Requested 0 bytes" ;
+
+ ok read($io, $buf, 3) == 3 ;
+ ok $buf eq "Thi";
+
+ ok sysread($io, $buf, 3, 2) == 3 ;
+ ok $buf eq "Ths i"
+ or print "# [$buf]\n" ;;
+ ok ! $io->eof;
+
+ # $io->seek(-4, 2);
+ #
+ # ok ! $io->eof;
+ #
+ # ok read($io, $buf, 20) == 4 ;
+ # ok $buf eq "e.\n\n";
+ #
+ # ok read($io, $buf, 20) == 0 ;
+ # ok $buf eq "";
+ #
+ # ok ! $io->eof;
+ }
+
+ }
+
+ {
+ # Read from non-compressed file
+
+ my $str = <<EOT;
+This is an example
+of a paragraph
+
+
+and a single line.
+
+EOT
+
+ my $lex = new LexFile my $name ;
+
+ writeFile($name, $str);
+ my @tmp;
+ my $buf;
+ {
+ my $io = new $UncompressClass $name, -Transparent => 1 ;
+
+ ok defined $io;
+ ok ! $io->eof;
+ ok $io->tell() == 0 ;
+ my @lines = <$io>;
+ ok @lines == 6;
+ ok $lines[1] eq "of a paragraph\n" ;
+ ok join('', @lines) eq $str ;
+ ok $. == 6;
+ ok $io->tell() == length($str) ;
+
+ ok $io->eof;
+
+ ok ! ( defined($io->getline) ||
+ (@tmp = $io->getlines) ||
+ defined(<$io>) ||
+ defined($io->getc) ||
+ read($io, $buf, 100) != 0) ;
+ }
+
+
+ {
+ local $/; # slurp mode
+ my $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my @lines = $io->getlines;
+ ok $io->eof;
+ ok @lines == 1 && $lines[0] eq $str;
+
+ $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my $line = <$io>;
+ ok $line eq $str;
+ ok $io->eof;
+ }
+
+ {
+ local $/ = ""; # paragraph mode
+ my $io = $UncompressClass->new($name);
+ ok ! $io->eof;
+ my @lines = <$io>;
+ ok $io->eof;
+ ok @lines == 2
+ or print "# exected 2 lines, got " . scalar(@lines) . "\n";
+ ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
+ or print "# [$lines[0]]\n" ;
+ ok $lines[1] eq "and a single line.\n\n";
+ }
+
+ {
+ local $/ = "is";
+ my $io = $UncompressClass->new($name);
+ my @lines = ();
+ my $no = 0;
+ my $err = 0;
+ ok ! $io->eof;
+ while (<$io>) {
+ push(@lines, $_);
+ $err++ if $. != ++$no;
+ }
+
+ ok $err == 0 ;
+ ok $io->eof;
+
+ ok @lines == 3 ;
+ ok join("-", @lines) eq
+ "This- is- an example\n" .
+ "of a paragraph\n\n\n" .
+ "and a single line.\n\n";
+ }
+
+
+ # Test read
+
+ {
+ my $io = $UncompressClass->new($name);
+
+ ok read($io, $buf, 3) == 3 ;
+ ok $buf eq "Thi";
+
+ ok sysread($io, $buf, 3, 2) == 3 ;
+ ok $buf eq "Ths i";
+ ok ! $io->eof;
+
+ # $io->seek(-4, 2);
+ #
+ # ok ! $io->eof;
+ #
+ # ok read($io, $buf, 20) == 4 ;
+ # ok $buf eq "e.\n\n";
+ #
+ # ok read($io, $buf, 20) == 0 ;
+ # ok $buf eq "";
+ #
+ # ok ! $io->eof;
+ }
+
+
+ }
+
+ {
+ # Vary the length parameter in a read
+
+ my $str = <<EOT;
+x
+x
+This is an example
+of a paragraph
+
+
+and a single line.
+
+EOT
+ $str = $str x 100 ;
+
+
+ foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
+ {
+ foreach my $trans (0, 1)
+ {
+ foreach my $append (0, 1)
+ {
+ title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
+
+ my $lex = new LexFile my $name ;
+
+ if ($trans) {
+ writeFile($name, $str) ;
+ }
+ else {
+ my $iow = new $CompressClass $name ;
+ print $iow $str ;
+ close $iow;
+ }
+
+
+ my $io = $UncompressClass->new($name,
+ -Append => $append,
+ -Transparent => $trans);
+
+ my $buf;
+
+ is $io->tell(), 0;
+
+ if ($append) {
+ 1 while $io->read($buf, $bufsize) > 0;
+ }
+ else {
+ my $tmp ;
+ $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
+ }
+ is length $buf, length $str;
+ ok $buf eq $str ;
+ ok ! $io->error() ;
+ ok $io->eof;
+ }
+ }
+ }
+ }
+
+ }
+}
+
+1;
--- /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;
+
+}
+
+sub run
+{
+ my $CompressClass = identify();
+ my $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($CompressClass);
+ my $UnError = getErrorRef($UncompressClass);
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+some more stuff on this line
+and finally...
+EOM
+
+ my $blocksize = 10 ;
+
+
+ my ($info, $compressed) = mkComplete($CompressClass, $hello);
+
+ my $header_size = $info->{HeaderLength};
+ my $trailer_size = $info->{TrailerLength};
+ my $fingerprint_size = $info->{FingerprintLength};
+ ok 1, "Compressed size is " . length($compressed) ;
+ ok 1, "Fingerprint size is $fingerprint_size" ;
+ ok 1, "Header size is $header_size" ;
+ ok 1, "Trailer size is $trailer_size" ;
+
+ for my $trans ( 0 .. 1)
+ {
+ title "Truncating $CompressClass, Transparent $trans";
+
+
+ foreach my $i (1 .. $fingerprint_size-1)
+ {
+ my $lex = new LexFile my $name ;
+
+ title "Fingerprint Truncation - length $i";
+
+ my $part = substr($compressed, 0, $i);
+ writeFile($name, $part);
+
+ my $gz = new $UncompressClass $name,
+ -BlockSize => $blocksize,
+ -Transparent => $trans;
+ if ($trans) {
+ ok $gz;
+ ok ! $gz->error() ;
+ my $buff ;
+ ok $gz->read($buff) == length($part) ;
+ ok $buff eq $part ;
+ ok $gz->eof() ;
+ $gz->close();
+ }
+ else {
+ ok !$gz;
+ }
+
+ }
+
+ #
+ # Any header corruption past the fingerprint is considered catastrophic
+ # so even if Transparent is set, it should still fail
+ #
+ foreach my $i ($fingerprint_size .. $header_size -1)
+ {
+ my $lex = new LexFile my $name ;
+
+ title "Header Truncation - length $i";
+
+ my $part = substr($compressed, 0, $i);
+ writeFile($name, $part);
+ ok ! defined new $UncompressClass $name,
+ -BlockSize => $blocksize,
+ -Transparent => $trans;
+ #ok $gz->eof() ;
+ }
+
+
+ foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size)
+ {
+ my $lex = new LexFile my $name ;
+
+ title "Compressed Data Truncation - length $i";
+
+ my $part = substr($compressed, 0, $i);
+ writeFile($name, $part);
+ ok my $gz = new $UncompressClass $name,
+ -BlockSize => $blocksize,
+ -Transparent => $trans;
+ my $un ;
+ my $status = 0 ;
+ $status = $gz->read($un) while $status >= 0 ;
+ ok $status < 0 ;
+ ok $gz->eof() ;
+ ok $gz->error() ;
+ $gz->close();
+ }
+
+ # RawDeflate does not have a trailer
+ next if $CompressClass eq 'IO::Compress::RawDeflate' ;
+
+ title "Compressed Trailer Truncation";
+ foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 )
+ {
+ foreach my $lax (0, 1)
+ {
+ my $lex = new LexFile my $name ;
+
+ ok 1, "Length $i, Lax $lax" ;
+ my $part = substr($compressed, 0, $i);
+ writeFile($name, $part);
+ ok my $gz = new $UncompressClass $name,
+ -BlockSize => $blocksize,
+ -Strict => !$lax,
+ -Append => 1,
+ -Transparent => $trans;
+ my $un = '';
+ my $status = 1 ;
+ $status = $gz->read($un) while $status > 0 ;
+
+ if ($lax)
+ {
+ is $un, $hello;
+ is $status, 0
+ or diag "Status $status Error is " . $gz->error() ;
+ ok $gz->eof()
+ or diag "Status $status Error is " . $gz->error() ;
+ ok ! $gz->error() ;
+ }
+ else
+ {
+ ok $status < 0
+ or diag "Status $status Error is " . $gz->error() ;
+ ok $gz->eof()
+ or diag "Status $status Error is " . $gz->error() ;
+ ok $gz->error() ;
+ }
+
+ $gz->close();
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+
+foreach my $CompressClass ( 'IO::Compress::RawDeflate')
+{
+ my $UncompressClass = getInverse($CompressClass);
+ my $Error = getErrorRef($UncompressClass);
+
+ my $compressed ;
+ ok( my $x = new IO::Compress::RawDeflate \$compressed);
+ ok $x->write($hello) ;
+ ok $x->close ;
+
+
+ my $cc = $compressed ;
+
+ my $gz ;
+ ok($gz = new $UncompressClass(\$cc,
+ -Transparent => 0))
+ or diag "$$Error\n";
+ my $un;
+ ok $gz->read($un) > 0 ;
+ ok $gz->close();
+ ok $un eq $hello ;
+
+ for my $trans (0 .. 1)
+ {
+ title "Testing $CompressClass, Transparent = $trans";
+
+ my $info = $gz->getHeaderInfo() ;
+ my $header_size = $info->{HeaderLength};
+ my $trailer_size = $info->{TrailerLength};
+ ok 1, "Compressed size is " . length($compressed) ;
+ ok 1, "Header size is $header_size" ;
+ ok 1, "Trailer size is $trailer_size" ;
+
+
+ title "Compressed Data Truncation";
+ foreach my $i (0 .. $blocksize)
+ {
+
+ my $lex = new LexFile my $name ;
+
+ ok 1, "Length $i" ;
+ my $part = substr($compressed, 0, $i);
+ writeFile($name, $part);
+ my $gz = new $UncompressClass $name,
+ -BlockSize => $blocksize,
+ -Transparent => $trans;
+ if ($trans) {
+ ok $gz;
+ ok ! $gz->error() ;
+ my $buff = '';
+ is $gz->read($buff), length $part ;
+ is $buff, $part ;
+ ok $gz->eof() ;
+ $gz->close();
+ }
+ else {
+ ok !$gz;
+ }
+ }
+
+ foreach my $i ($blocksize+1 .. length($compressed)-1)
+ {
+
+ my $lex = new LexFile my $name ;
+
+ ok 1, "Length $i" ;
+ my $part = substr($compressed, 0, $i);
+ writeFile($name, $part);
+ ok my $gz = new $UncompressClass $name,
+ -BlockSize => $blocksize,
+ -Transparent => $trans;
+ my $un ;
+ my $status = 0 ;
+ $status = $gz->read($un) while $status >= 0 ;
+ ok $status < 0 ;
+ ok $gz->eof() ;
+ ok $gz->error() ;
+ $gz->close();
+ }
+ }
+
+}
+
--- /dev/null
+
+use strict;
+use warnings;
+use bytes;
+
+use Test::More ;
+use ZlibTestUtils;
+
+BEGIN
+{
+ # use Test::NoWarnings, if available
+ my $extra = 0 ;
+ $extra = 1
+ if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
+
+ plan tests => 49 + $extra ;
+}
+
+
+
+my $CompressClass = identify();
+my $UncompressClass = getInverse($CompressClass);
+my $Error = getErrorRef($CompressClass);
+my $UnError = getErrorRef($UncompressClass);
+
+use Compress::Zlib;
+use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+
+sub myGZreadFile
+{
+ my $filename = shift ;
+ my $init = shift ;
+
+
+ my $fil = new $UncompressClass $filename,
+ -Strict => 1,
+ -Append => 1
+ ;
+
+ my $data = '';
+ $data = $init if defined $init ;
+ 1 while $fil->read($data) > 0;
+
+ $fil->close ;
+ return $data ;
+}
+
+
+{
+
+ title "Testing $CompressClass Errors";
+
+}
+
+
+{
+ title "Testing $UncompressClass Errors";
+
+}
+
+{
+ title "Testing $CompressClass and $UncompressClass";
+
+ {
+ title "flush" ;
+
+
+ my $lex = new LexFile my $name ;
+
+ my $hello = <<EOM ;
+hello world
+this is a test
+EOM
+
+ {
+ my $x ;
+ ok $x = new $CompressClass $name ;
+
+ ok $x->write($hello), "write" ;
+ ok $x->flush(Z_FINISH), "flush";
+ ok $x->close, "close" ;
+ }
+
+ {
+ my $uncomp;
+ ok my $x = new $UncompressClass $name, -Append => 1 ;
+
+ my $len ;
+ 1 while ($len = $x->read($uncomp)) > 0 ;
+
+ is $len, 0, "read returned 0";
+
+ ok $x->close ;
+ is $uncomp, $hello ;
+ }
+ }
+
+
+ if ($CompressClass ne 'RawDeflate')
+ {
+ # write empty file
+ #========================================
+
+ my $buffer = '';
+ {
+ my $x ;
+ ok $x = new $CompressClass(\$buffer) ;
+ ok $x->close ;
+
+ }
+
+ my $keep = $buffer ;
+ my $uncomp= '';
+ {
+ my $x ;
+ ok $x = new $UncompressClass(\$buffer, Append => 1) ;
+
+ 1 while $x->read($uncomp) > 0 ;
+
+ ok $x->close ;
+ }
+
+ ok $uncomp eq '' ;
+ ok $buffer eq $keep ;
+
+ }
+
+
+ {
+ title "inflateSync on plain file";
+
+ my $hello = "I am a HAL 9000 computer" x 2001 ;
+
+ my $k = new $UncompressClass(\$hello, Transparent => 1);
+ ok $k ;
+
+ # Skip to the flush point -- no-op for plain file
+ my $status = $k->inflateSync();
+ is $status, 1
+ or diag $k->error() ;
+
+ my $rest;
+ is $k->read($rest, length($hello)), length($hello)
+ or diag $k->error() ;
+ ok $rest eq $hello ;
+
+ ok $k->close();
+ }
+
+ {
+ title "$CompressClass: inflateSync for real";
+
+ # create a deflate stream with flush points
+
+ my $hello = "I am a HAL 9000 computer" x 2001 ;
+ my $goodbye = "Will I dream?" x 2010;
+ my ($x, $err, $answer, $X, $Z, $status);
+ my $Answer ;
+
+ ok ($x = new $CompressClass(\$Answer));
+ ok $x ;
+
+ is $x->write($hello), length($hello);
+
+ # create a flush point
+ ok $x->flush(Z_FULL_FLUSH) ;
+
+ is $x->write($goodbye), length($goodbye);
+
+ ok $x->close() ;
+
+ my $k;
+ $k = new $UncompressClass(\$Answer, BlockSize => 1);
+ ok $k ;
+
+ my $initial;
+ is $k->read($initial, 1), 1 ;
+ is $initial, substr($hello, 0, 1);
+
+ # Skip to the flush point
+ $status = $k->inflateSync();
+ is $status, 1, " inflateSync returned 1"
+ or diag $k->error() ;
+
+ my $rest;
+ is $k->read($rest, length($hello) + length($goodbye)),
+ length($goodbye)
+ or diag $k->error() ;
+ ok $rest eq $goodbye, " got expected output" ;
+
+ ok $k->close();
+ }
+
+ {
+ title "$CompressClass: inflateSync no FLUSH point";
+
+ # create a deflate stream with flush points
+
+ my $hello = "I am a HAL 9000 computer" x 2001 ;
+ my ($x, $err, $answer, $X, $Z, $status);
+ my $Answer ;
+
+ ok ($x = new $CompressClass(\$Answer));
+ ok $x ;
+
+ is $x->write($hello), length($hello);
+
+ ok $x->close() ;
+
+ my $k = new $UncompressClass(\$Answer, BlockSize => 1);
+ ok $k ;
+
+ my $initial;
+ is $k->read($initial, 1), 1 ;
+ is $initial, substr($hello, 0, 1);
+
+ # Skip to the flush point
+ $status = $k->inflateSync();
+ is $status, 0
+ or diag $k->error() ;
+
+ ok $k->close();
+ is $k->inflateSync(), 0 ;
+ }
+
+}
+
+
+1;
+
+
+
+
projects / p5sagit/p5-mst-13.2.git / commitdiff