From: Paul Marquess Date: Fri, 3 Mar 2006 10:25:48 +0000 (+0000) Subject: Compress::Zlib X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=25f0751fb55a0f87a7e18ae8960f9acf2407ae32;p=p5sagit%2Fp5-mst-13.2.git Compress::Zlib From: "Paul Marquess" Message-ID: <007101c63eac$d919c6c0$4c05140a@myopwv.com> p4raw-id: //depot/perl@27384 --- diff --git a/MANIFEST b/MANIFEST index 194f1c6..5cbda5e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -144,130 +144,156 @@ ext/ByteLoader/byterun.c Runtime support for bytecode loader ext/ByteLoader/byterun.h Header for byterun.c ext/ByteLoader/hints/sunos.pl Hints for named architecture ext/ByteLoader/Makefile.PL Bytecode loader makefile writer -ext/Compress/Zlib/Changes Compress::Zlib -ext/Compress/Zlib/config.in Compress::Zlib -ext/Compress/Zlib/examples/filtdef Compress::Zlib -ext/Compress/Zlib/examples/filtinf Compress::Zlib -ext/Compress/Zlib/examples/gzcat Compress::Zlib -ext/Compress/Zlib/examples/gzcat.zlib Compress::Zlib -ext/Compress/Zlib/examples/gzgrep Compress::Zlib -ext/Compress/Zlib/examples/gzstream Compress::Zlib -ext/Compress/Zlib/fallback/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/README Compress::Zlib +ext/Compress/Raw/Zlib/t/01version.t Compress::Raw::Zlib +ext/Compress/Raw/Zlib/t/02zlib.t Compress::Raw::Zlib +ext/Compress/Raw/Zlib/t/07bufsize.t Compress::Raw::Zlib +ext/Compress/Raw/Zlib/t/18lvalue.t Compress::Raw::Zlib +ext/Compress/Raw/Zlib/t/99pod.t Compress::Raw::Zlib +ext/Compress/Raw/Zlib/Zlib.xs Compress::Raw::Zlib +ext/Compress/Raw/Zlib/typemap Compress::Raw::Zlib +ext/Compress/Raw/Zlib/Makefile.PL Compress::Raw::Zlib +ext/Compress/Raw/Zlib/ppport.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/config.in Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/adler32.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/compress.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/crc32.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/crc32.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/deflate.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/deflate.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/infback.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/inffast.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/inffast.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/inffixed.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/inflate.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/inflate.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/inftrees.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/inftrees.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/trees.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/trees.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/uncompr.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/zconf.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/zlib.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/zutil.c Compress::Raw::Zlib +ext/Compress/Raw/Zlib/zlib-src/zutil.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/fallback/constants.h Compress::Raw::Zlib +ext/Compress/Raw/Zlib/fallback/constants.xs Compress::Raw::Zlib +ext/Compress/Raw/Zlib/lib/Compress/Raw/Zlib.pm Compress::Raw::Zlib +ext/Compress/Raw/Zlib/examples/filtdef Compress::Raw::Zlib +ext/Compress/Raw/Zlib/examples/filtinf Compress::Raw::Zlib +ext/Compress/Raw/Zlib/private/MakeUtil.pm Compress::Raw::Zlib +ext/Compress/Raw/Zlib/README Compress::Raw::Zlib +ext/Compress/Zlib/lib/Compress/Zlib.pm 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/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/08encoding.t Compress::Zlib -ext/Compress/Zlib/t/09gziphdr.t Compress::Zlib -ext/Compress/Zlib/t/10defhdr.t Compress::Zlib -ext/Compress/Zlib/t/11truncate.t Compress::Zlib -ext/Compress/Zlib/t/12any-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-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-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 -ext/Compress/Zlib/zlib-src/adler32.c Compress::Zlib -ext/Compress/Zlib/zlib-src/compress.c Compress::Zlib -ext/Compress/Zlib/zlib-src/crc32.c Compress::Zlib -ext/Compress/Zlib/zlib-src/crc32.h Compress::Zlib -ext/Compress/Zlib/zlib-src/deflate.c Compress::Zlib -ext/Compress/Zlib/zlib-src/deflate.h Compress::Zlib -ext/Compress/Zlib/zlib-src/infback.c Compress::Zlib -ext/Compress/Zlib/zlib-src/inffast.c Compress::Zlib -ext/Compress/Zlib/zlib-src/inffast.h Compress::Zlib -ext/Compress/Zlib/zlib-src/inffixed.h Compress::Zlib -ext/Compress/Zlib/zlib-src/inflate.c Compress::Zlib -ext/Compress/Zlib/zlib-src/inflate.h Compress::Zlib -ext/Compress/Zlib/zlib-src/inftrees.c Compress::Zlib -ext/Compress/Zlib/zlib-src/inftrees.h Compress::Zlib -ext/Compress/Zlib/zlib-src/trees.c Compress::Zlib -ext/Compress/Zlib/zlib-src/trees.h Compress::Zlib -ext/Compress/Zlib/zlib-src/uncompr.c Compress::Zlib -ext/Compress/Zlib/zlib-src/zconf.h Compress::Zlib -ext/Compress/Zlib/zlib-src/zlib.h Compress::Zlib -ext/Compress/Zlib/zlib-src/zutil.c Compress::Zlib -ext/Compress/Zlib/zlib-src/zutil.h Compress::Zlib -ext/Compress/Zlib/Zlib.xs Compress::Zlib +ext/Compress/Zlib/examples/filtdef Compress::Zlib +ext/Compress/Zlib/examples/filtinf Compress::Zlib +ext/Compress/Zlib/examples/gzcat Compress::Zlib +ext/Compress/Zlib/examples/gzgrep Compress::Zlib +ext/Compress/Zlib/examples/gzstream Compress::Zlib +ext/Compress/Zlib/Makefile.PL Compress::Zlib +ext/Compress/Zlib/README Compress::Zlib +ext/Compress/Zlib/private/MakeUtil.pm Compress::Zlib +ext/Compress/Zlib/Changes Compress::Zlib +ext/Compress/IO/Base/lib/IO/Uncompress/Base.pm IO::Compress::Base +ext/Compress/IO/Base/lib/IO/Uncompress/AnyUncompress.pm IO::Compress::Base +ext/Compress/IO/Base/lib/IO/Compress/Base.pm IO::Compress::Base +ext/Compress/IO/Base/lib/IO/Compress/Base/Common.pm IO::Compress::Base +ext/Compress/IO/Base/lib/File/GlobMapper.pm IO::Compress::Base +ext/Compress/IO/Base/Makefile.PL IO::Compress::Base +ext/Compress/IO/Base/t/01misc.t IO::Compress::Base +ext/Compress/IO/Base/t/globmapper.t IO::Compress::Base +ext/Compress/IO/Base/t/99pod.t IO::Compress::Base +ext/Compress/IO/Base/private/MakeUtil.pm IO::Compress::Base +ext/Compress/IO/Base/Changes IO::Compress::Base +ext/Compress/IO/Base/README IO::Compress::Base +ext/Compress/IO/Zlib/t/100generic-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/100generic-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/020isize.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/002any-transparent.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/004gziphdr.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/102tied-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/005defhdr.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/010examples.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/101truncate-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/002any-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/001zlib-generic-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/999pod.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/050interop-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/002any-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/100generic-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/101truncate-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/101truncate-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/102tied-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/105oneshot-gzip-only.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/105oneshot-zip-only.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/108anyunc-transparent.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/107multi-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/106prime-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/105oneshot-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/109merge-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/106prime-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/105oneshot-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/104destroy-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/107multi-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/102tied-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/105oneshot-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/001zlib-generic-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/109merge-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/109merge-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/103newtied-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/103newtied-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/109merge-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/001zlib-generic-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/108anyunc-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/107multi-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/106prime-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/001zlib-generic-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/101truncate-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/002any-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/002any-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/102tied-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/106prime-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/107multi-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/108anyunc-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/104destroy-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/104destroy-zip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/105oneshot-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/103newtied-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/103newtied-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/104destroy-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/108anyunc-gzip.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/108anyunc-rawdeflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/t/100generic-deflate.t IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Uncompress/Gunzip.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Uncompress/AnyInflate.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Uncompress/RawInflate.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Uncompress/Inflate.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Uncompress/Unzip.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Uncompress/Adapter/Identity.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Uncompress/Adapter/Inflate.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Compress/Gzip.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Compress/Deflate.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Compress/RawDeflate.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Compress/Zip.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Compress/Zip/Constants.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Compress/Gzip/Constants.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Compress/Zlib/Constants.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Compress/Adapter/Deflate.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/lib/IO/Compress/Adapter/Identity.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/Makefile.PL IO::Compress::Zlib +ext/Compress/IO/Zlib/examples/gzcat IO::Compress::Zlib +ext/Compress/IO/Zlib/examples/gzstream IO::Compress::Zlib +ext/Compress/IO/Zlib/examples/gzgrep IO::Compress::Zlib +ext/Compress/IO/Zlib/examples/gzappend IO::Compress::Zlib +ext/Compress/IO/Zlib/examples/unzip IO::Compress::Zlib +ext/Compress/IO/Zlib/README IO::Compress::Zlib +ext/Compress/IO/Zlib/private/MakeUtil.pm IO::Compress::Zlib +ext/Compress/IO/Zlib/Changes IO::Compress::Zlib ext/Cwd/Changes Cwd extension Changelog ext/Cwd/Cwd.xs Cwd extension external subroutines ext/Cwd/Makefile.PL Cwd extension makefile maker @@ -3084,7 +3110,7 @@ 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/compress/ZlibTestUtils.pm Compress::Zlib +t/lib/compress/CompTestUtils.pm 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 diff --git a/ext/Compress/IO/Base/Changes b/ext/Compress/IO/Base/Changes new file mode 100644 index 0000000..a3293e3 --- /dev/null +++ b/ext/Compress/IO/Base/Changes @@ -0,0 +1,11 @@ +CHANGES +------- + + 2.000_08 2 March 2006 + + * Split IO::Compress::Base into its own distribution. + + * Added opened, autoflush and input_line_number. + + * Beefed up support for $. + diff --git a/ext/Compress/IO/Base/Makefile.PL b/ext/Compress/IO/Base/Makefile.PL new file mode 100644 index 0000000..2aaecb5 --- /dev/null +++ b/ext/Compress/IO/Base/Makefile.PL @@ -0,0 +1,41 @@ +#! perl -w + +use strict ; +require 5.004 ; + +use private::MakeUtil; +use ExtUtils::MakeMaker 5.16 ; + +UpDowngrade(getPerlFiles('MANIFEST')) + unless $ENV{PERL_CORE}; + +WriteMakefile( + NAME => 'IO::Compress::Base', + VERSION_FROM => 'lib/IO/Compress/Base.pm', + 'dist' => { COMPRESS => 'gzip', + TARFLAGS => '-chvf', + SUFFIX => 'gz', + DIST_DEFAULT => 'MyTrebleCheck tardist', + }, + + ( + $ENV{SKIP_FOR_CORE} + ? (MAN3PODS => {}) + : (PREREQ_PM => { 'Scalar::Util' => 0, + $] >= 5.005 && $] < 5.006 + ? ('File::BSDGlob' => 0) + : () } + ) + ), + + ( + $] >= 5.005 + ? (ABSTRACT_FROM => 'lib/IO/Compress/Base.pm', + AUTHOR => 'Paul Marquess ') + : () + ), + +) ; + +# end of file Makefile.PL + diff --git a/ext/Compress/IO/Base/README b/ext/Compress/IO/Base/README new file mode 100644 index 0000000..6f06827 --- /dev/null +++ b/ext/Compress/IO/Base/README @@ -0,0 +1,146 @@ + + IO::Compress::Base + + Version 2.000_08 + + 27 Feb 2006 + + + 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. + + + + + WARNING + THIS IS BETA CODE. + + DO NOT use in production code. + Please report any problems. + +DESCRIPTION +----------- + + +This module is a base class for all IO::Compress and IO::Uncompress +modules. + + + + + +PREREQUISITES +------------- + +Before you can build IO::Compress::Base you need to have the following +installed on your system: + + + * Perl 5.004 or better. + + + + + +BUILDING THE MODULE +------------------- + +Assuming you have met all the prerequisites, the module can now be built +using this sequence of commands: + + perl Makefile.PL + make + make test + + + +INSTALLATION +------------ + +To install IO::Compress::Base, run the command below: + + make install + + + + + +TROUBLESHOOTING +--------------- + + + + + + + + + + + + +FEEDBACK +-------- + +How to report a problem with IO::Compress::Base. + +To help me help you, I need all of the following information: + + 1. The Versions of everything relevant. + This includes: + + a. The *complete* output from running this + + perl -V + + Do not edit the output in any way. + Note, I want you to run "perl -V" and NOT "perl -v". + + If your perl does not understand the "-V" option it is too + old. This module needs Perl version 5.004 or better. + + b. The version of IO::Compress::Base you have. + If you have successfully installed IO::Compress::Base, this one-liner + will tell you: + + perl -MIO::Compress::Base -e 'print qq[ver $IO::Compress::Base::VERSION\n]' + + If you areplete* output from running this + + perl -V + + Do not edit the output in any way. + Note, I want you to run "perl -V" and NOT "perl -v". + + If your perl does not understand the "-V" option it is too + old. This module needs Perl version 5.004 or better. + + b. The version of IO::Compress::Base you have. + If you have successfully installed IO::Compress::Base, this one-liner + will tell you: + + perl -MIO::Compress::Base -e 'print qq[ver $IO::Compress::Base::VERSION\n]' + + If you are running windows use this + + perl -MIO::Compress::Base -e "print qq[ver $IO::Compress::Base::VERSION\n]" + + If you haven't installed IO::Compress::Base then search IO::Compress::Base.pm + for a line like this: + + $VERSION = "1.05" ; + + + + 2. If you are having problems building IO::Compress::Base, send me a + complete log of what happened. Start by unpacking the IO::Compress::Base + module into a fresh directory and keep a log of all the steps + + [edit config.in, if necessary] + perl Makefile.PL + make + make test TEST_VERBOSE=1 + + +Paul Marquess diff --git a/ext/Compress/IO/Base/lib/File/GlobMapper.pm b/ext/Compress/IO/Base/lib/File/GlobMapper.pm new file mode 100644 index 0000000..9e7c217 --- /dev/null +++ b/ext/Compress/IO/Base/lib/File/GlobMapper.pm @@ -0,0 +1,697 @@ +package File::GlobMapper; + +use strict; +use warnings; +use Carp; + +our ($CSH_GLOB); + +BEGIN +{ + if ($] < 5.006) + { + require File::BSDGlob; import File::BSDGlob qw(:glob) ; + $CSH_GLOB = File::BSDGlob::GLOB_CSH() ; + *globber = \&File::BSDGlob::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::csh_glob; + } +} + +our ($Error); + +our ($VERSION, @EXPORT_OK); +$VERSION = '0.000_02'; +@EXPORT_OK = qw( globmap ); + + +our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount); +$noPreBS = '(? '([^/]*)', + '?' => '([^/])', + '.' => '\.', + '[' => '([', + '(' => '(', + ')' => ')', + ); + +%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /; + +sub globmap ($$;) +{ + my $inputGlob = shift ; + my $outputGlob = shift ; + + my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_) + or croak "globmap: $Error" ; + return $obj->getFileMap(); +} + +sub new +{ + my $class = shift ; + my $inputGlob = shift ; + my $outputGlob = shift ; + # TODO -- flags needs to default to whatever File::Glob does + my $flags = shift || $CSH_GLOB ; + #my $flags = shift ; + + $inputGlob =~ s/^\s*\<\s*//; + $inputGlob =~ s/\s*\>\s*$//; + + $outputGlob =~ s/^\s*\<\s*//; + $outputGlob =~ s/\s*\>\s*$//; + + my %object = + ( InputGlob => $inputGlob, + OutputGlob => $outputGlob, + GlobFlags => $flags, + Braces => 0, + WildCount => 0, + Pairs => [], + Sigil => '#', + ); + + my $self = bless \%object, ref($class) || $class ; + + $self->_parseInputGlob() + or return undef ; + + $self->_parseOutputGlob() + or return undef ; + + my @inputFiles = globber($self->{InputGlob}, $flags) ; + + if (GLOB_ERROR) + { + $Error = $!; + return undef ; + } + + #if (whatever) + { + my $missing = grep { ! -e $_ } @inputFiles ; + + if ($missing) + { + $Error = "$missing input files do not exist"; + return undef ; + } + } + + $self->{InputFiles} = \@inputFiles ; + + $self->_getFiles() + or return undef ; + + return $self; +} + +sub _retError +{ + my $string = shift ; + $Error = "$string in input fileglob" ; + return undef ; +} + +sub _unmatched +{ + my $delimeter = shift ; + + _retError("Unmatched $delimeter"); + return undef ; +} + +sub _parseBit +{ + my $self = shift ; + + my $string = shift ; + + my $out = ''; + my $depth = 0 ; + + while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//) + { + $out .= quotemeta($1) ; + $out .= $mapping{$2} if defined $mapping{$2}; + + ++ $self->{WildCount} if $wildCount{$2} ; + + if ($2 eq ',') + { + return _unmatched "(" + if $depth ; + + $out .= '|'; + } + elsif ($2 eq '(') + { + ++ $depth ; + } + elsif ($2 eq ')') + { + return _unmatched ")" + if ! $depth ; + + -- $depth ; + } + elsif ($2 eq '[') + { + # TODO -- quotemeta & check no '/' + # TODO -- check for \] & other \ within the [] + $string =~ s#(.*?\])## + or return _unmatched "[" ; + $out .= "$1)" ; + } + elsif ($2 eq ']') + { + return _unmatched "]" ; + } + elsif ($2 eq '{' || $2 eq '}') + { + return _retError "Nested {} not allowed" ; + } + } + + $out .= quotemeta $string; + + return _unmatched "(" + if $depth ; + + return $out ; +} + +sub _parseInputGlob +{ + my $self = shift ; + + my $string = $self->{InputGlob} ; + my $inGlob = ''; + + # Multiple concatenated *'s don't make sense + #$string =~ s#\*\*+#*# ; + + # TODO -- Allow space to delimit patterns? + #my @strings = split /\s+/, $string ; + #for my $str (@strings) + my $out = ''; + my $depth = 0 ; + + while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//) + { + $out .= quotemeta($1) ; + $out .= $mapping{$2} if defined $mapping{$2}; + ++ $self->{WildCount} if $wildCount{$2} ; + + if ($2 eq '(') + { + ++ $depth ; + } + elsif ($2 eq ')') + { + return _unmatched ")" + if ! $depth ; + + -- $depth ; + } + elsif ($2 eq '[') + { + # TODO -- quotemeta & check no '/' or '(' or ')' + # TODO -- check for \] & other \ within the [] + $string =~ s#(.*?\])## + or return _unmatched "["; + $out .= "$1)" ; + } + elsif ($2 eq ']') + { + return _unmatched "]" ; + } + elsif ($2 eq '}') + { + return _unmatched "}" ; + } + elsif ($2 eq '{') + { + # TODO -- check no '/' within the {} + # TODO -- check for \} & other \ within the {} + + my $tmp ; + unless ( $string =~ s/(.*?)$noPreBS\}//) + { + return _unmatched "{"; + } + #$string =~ s#(.*?)\}##; + + #my $alt = join '|', + # map { quotemeta $_ } + # split "$noPreBS,", $1 ; + my $alt = $self->_parseBit($1); + defined $alt or return 0 ; + $out .= "($alt)" ; + + ++ $self->{Braces} ; + } + } + + return _unmatched "(" + if $depth ; + + $out .= quotemeta $string ; + + + $self->{InputGlob} =~ s/$noPreBS[\(\)]//g; + $self->{InputPattern} = $out ; + + #print "# INPUT '$self->{InputGlob}' => '$out'\n"; + + return 1 ; + +} + +sub _parseOutputGlob +{ + my $self = shift ; + + my $string = $self->{OutputGlob} ; + my $maxwild = $self->{WildCount}; + + if ($self->{GlobFlags} & GLOB_TILDE) + #if (1) + { + $string =~ s{ + ^ ~ # find a leading tilde + ( # save this in $1 + [^/] # a non-slash character + * # repeated 0 or more times (0 means me) + ) + }{ + $1 + ? (getpwnam($1))[7] + : ( $ENV{HOME} || $ENV{LOGDIR} ) + }ex; + + } + + # max #1 must be == to max no of '*' in input + while ( $string =~ m/#(\d)/g ) + { + croak "Max wild is #$maxwild, you tried #$1" + if $1 > $maxwild ; + } + + my $noPreBS = '(?{OutputGlob}' => '$string'\n"; + $self->{OutputPattern} = $string ; + + return 1 ; +} + +sub _getFiles +{ + my $self = shift ; + + my %outInMapping = (); + my %inFiles = () ; + + foreach my $inFile (@{ $self->{InputFiles} }) + { + next if $inFiles{$inFile} ++ ; + + my $outFile = $inFile ; + + if ( $inFile =~ m/$self->{InputPattern}/ ) + { + no warnings 'uninitialized'; + eval "\$outFile = $self->{OutputPattern};" ; + + if (defined $outInMapping{$outFile}) + { + $Error = "multiple input files map to one output file"; + return undef ; + } + $outInMapping{$outFile} = $inFile; + push @{ $self->{Pairs} }, [$inFile, $outFile]; + } + } + + return 1 ; +} + +sub getFileMap +{ + my $self = shift ; + + return $self->{Pairs} ; +} + +sub getHash +{ + my $self = shift ; + + return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ; +} + +1; + +__END__ + +=head1 NAME + +File::GlobMapper - Extend File Glob to Allow Input and Output Files + +=head1 SYNOPSIS + + use File::GlobMapper qw( globmap ); + + my $aref = globmap $input => $output + or die $File::GlobMapper::Error ; + + my $gm = new File::GlobMapper $input => $output + or die $File::GlobMapper::Error ; + + +=head1 DESCRIPTION + +B + +=over 5 + +=item * This code is a work in progress. + +=item * There are known bugs. + +=item * The interface defined here is tentative. + +=item * There are portability issues. + +=item * Do not use in production code. + +=item * Consider yourself warned! + +=back + +This module needs Perl5.005 or better. + +This module takes the existing C module as a starting point and +extends it to allow new filenames to be derived from the files matched by +C. + +This can be useful when carrying out batch operations on multiple files that +have both an input filename and output filename and the output file can be +derived from the input filename. Examples of operations where this can be +useful include, file renaming, file copying and file compression. + + +=head2 Behind The Scenes + +To help explain what C 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 directory + + alpha.tar.gz + beta.tar.gz + gamma.tar.gz + +and they need renamed to this + + alpha.tgz + beta.tgz + gamma.tgz + +Below is a possible implementation of a script to carry out the rename +(error cases have been omitted) + + foreach my $old ( glob "*.tar.gz" ) + { + my $new = $old; + $new =~ s#(.*)\.tar\.gz$#$1.tgz# ; + + rename $old => $new + or die "Cannot rename '$old' to '$new': $!\n; + } + +Notice that a file glob pattern C<*.tar.gz> was used to match the +C<.tar.gz> files, then a fairly similar regular expression was used in +the substitute to allow the new filename to be created. + +Given that the file glob is just a cut-down regular expression and that it +has already done a lot of the hard work in pattern matching the filenames, +wouldn't it be handy to be able to use the patterns in the fileglob to +drive the new filename? + +Well, that's I what C does. + +Here is same snippet of code rewritten using C + + for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' ) + { + my ($from, $to) = @$pair; + rename $from => $to + or die "Cannot rename '$old' to '$new': $!\n; + } + +So how does it work? + +Behind the scenes the C function does a combination of a +file glob to match existing filenames followed by a substitute +to create the new filenames. + +Notice how both parameters to C are strings that are 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 delimiters if they are +present. + +The first parameter to C, C<*.tar.gz>, is an I. +Once the enclosing "< ... >" is removed, this is passed (more or +less) unchanged to C to carry out a file match. + +Next the fileglob C<*.tar.gz> is transformed behind the scenes into a +full Perl regular expression, with the additional step of wrapping each +transformed wildcard metacharacter sequence in parenthesis. + +In this case the input fileglob C<*.tar.gz> will be transformed into +this Perl regular expression + + ([^/]*)\.tar\.gz + +Wrapping with parenthesis allows the wildcard parts of the Input File +Glob to be referenced by the second parameter to C, C<#1.tgz>, +the I. This parameter operates just like the replacement +part of a substitute command. The difference is that the C<#1> syntax +is used to reference sub-patterns matched in the input fileglob, rather +than the C<$1> syntax that is used with perl regular expressions. In +this case C<#1> is used to refer to the text matched by the C<*> in the +Input File Glob. This makes it easier to use this module where the +parameters to C are typed at the command line. + +The final step involves passing each filename matched by the C<*.tar.gz> +file glob through the derived Perl regular expression in turn and +expanding the output fileglob using it. + +The end result of all this is a list of pairs of filenames. By default +that is what is returned by C. In this example the data structure +returned will look like this + + ( ['alpha.tar.gz' => 'alpha.tgz'], + ['beta.tar.gz' => 'beta.tgz' ], + ['gamma.tar.gz' => 'gamma.tgz'] + ) + + +Each pair is an array reference with two elements - namely the I +filename, that C has matched, and a I filename that is +derived from the I filename. + + + +=head2 Limitations + +C has been kept simple deliberately, so it isn't intended to +solve all filename mapping operations. Under the hood C (or for +older versions of Perl, C) is used to match the files, so you +will never have the flexibility of full Perl regular expression. + +=head2 Input File Glob + +The syntax for an Input FileGlob is identical to C, except +for the following + +=over 5 + +=item 1. + +No nested {} + +=item 2. + +Whitespace does not delimit fileglobs. + +=item 3. + +The use of parenthesis can be used to capture parts of the input filename. + +=item 4. + +If an Input glob matches the same file more than once, only the first +will be used. + +=back + +The syntax + +=over 5 + +=item B<~> + +=item B<~user> + + +=item B<.> + +Matches a literal '.'. +Equivalent to the Perl regular expression + + \. + +=item B<*> + +Matches zero or more characters, except '/'. Equivalent to the Perl +regular expression + + [^/]* + +=item B + +Matches zero or one character, except '/'. Equivalent to the Perl +regular expression + + [^/]? + +=item B<\> + +Backslash is used, as usual, to escape the next character. + +=item B<[]> + +Character class. + +=item B<{,}> + +Alternation + +=item B<()> + +Capturing parenthesis that work just like perl + +=back + +Any other character it taken literally. + +=head2 Output File Glob + +The Output File Glob is a normal string, with 2 glob-like features. + +The first is the '*' metacharacter. This will be replaced by the complete +filename matched by the input file glob. So + + *.c *.Z + +The second is + +Output FileGlobs take the + +=over 5 + +=item "*" + +The "*" character will be replaced with the complete input filename. + +=item #1 + +Patterns of the form /#\d/ will be replaced with the + +=back + +=head2 Returned Data + + +=head1 EXAMPLES + +=head2 A Rename script + +Below is a simple "rename" script that uses C to determine the +source and destination filenames. + + use File::GlobMapper qw(globmap) ; + use File::Copy; + + die "rename: Usage rename 'from' 'to'\n" + unless @ARGV == 2 ; + + my $fromGlob = shift @ARGV; + my $toGlob = shift @ARGV; + + my $pairs = globmap($fromGlob, $toGlob) + or die $File::GlobMapper::Error; + + for my $pair (@$pairs) + { + my ($from, $to) = @$pair; + move $from => $to ; + } + + + +Here is an example that renames all c files to cpp. + + $ rename '*.c' '#1.cpp' + +=head2 A few example globmaps + +Below are a few examples of globmaps + +To copy all your .c file to a backup directory + + '' '' + +If you want to compress all + + '' '<*.gz>' + +To uncompress + + '' '' + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +The I module was written by Paul Marquess, F. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005 Paul Marquess. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/ext/Compress/IO/Base/lib/IO/Compress/Base.pm b/ext/Compress/IO/Base/lib/IO/Compress/Base.pm new file mode 100644 index 0000000..19669e2 --- /dev/null +++ b/ext/Compress/IO/Base/lib/IO/Compress/Base.pm @@ -0,0 +1,993 @@ + +package IO::Compress::Base ; + +require 5.004 ; + +use strict ; +use warnings; + +use IO::Compress::Base::Common; + +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_08'; + +#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 || IO::Compress::Base::Parameters::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 $status = *$self->{Compress}->flush(*$self->{Buffer}, @_) ; + 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, $!, $!); + defined *$self->{FH}->flush() + 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->{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 opened +{ + my $self = shift ; + return ! *$self->{Closed} ; +} + +sub autoflush +{ + my $self = shift ; + return defined *$self->{FH} + ? *$self->{FH}->autoflush(@_) + : undef ; +} + +sub input_line_number +{ + return undef ; +} + + +sub _notAvailable +{ + my $name = shift ; + return sub { croak "$name Not Available: File opened only for output" ; } ; +} + +*read = _notAvailable('read'); +*READ = _notAvailable('read'); +*readline = _notAvailable('readline'); +*READLINE = _notAvailable('readline'); +*getc = _notAvailable('getc'); +*GETC = _notAvailable('getc'); + +*FILENO = \&fileno; +*PRINT = \&print; +*PRINTF = \&printf; +*WRITE = \&syswrite; +*write = \&syswrite; +*SEEK = \&seek; +*TELL = \&tell; +*EOF = \&eof; +*CLOSE = \&close; +*BINMODE = \&binmode; + +#*sysread = \&_notAvailable; +#*syswrite = \&_write; + +1; + +__END__ + +=head1 NAME + + +IO::Compress::Base - Base Class for IO::Compress modules + + +=head1 SYNOPSIS + + use IO::Compress::Base ; + +=head1 DESCRIPTION + + +This module is not intended for direct use in application code. Its sole +purpose if to to be sub-classed by IO::Compress modules. + + + + +=head1 SEE ALSO + +L, L, L, L, L, L, L, L, L, L, L, L, L + +L + +L, L, +L, +L + + + + + + + + +=head1 AUTHOR + +The I module was written by Paul Marquess, +F. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005-2006 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + diff --git a/ext/Compress/IO/Base/lib/IO/Compress/Base/Common.pm b/ext/Compress/IO/Base/lib/IO/Compress/Base/Common.pm new file mode 100644 index 0000000..dc6ea41 --- /dev/null +++ b/ext/Compress/IO/Base/lib/IO/Compress/Base/Common.pm @@ -0,0 +1,702 @@ +package IO::Compress::Base::Common; + +use strict ; +use warnings; +use bytes; + +use Carp; +use Scalar::Util qw(blessed readonly); +use File::GlobMapper; + +require Exporter; +our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS); +@ISA = qw(Exporter); +$VERSION = '2.000_08'; + +@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput + isaFileGlobString cleanFileGlobString oneTarget + setBinModeInput setBinModeOutput + ckInOutParams + createSelfTiedObject + + WANT_CODE + WANT_EXT + WANT_UNDEF + WANT_HASH + + STATUS_OK + STATUS_ENDSTREAM + STATUS_EOF + STATUS_ERROR + ); + +%EXPORT_TAGS = ( Status => [qw( STATUS_OK + STATUS_ENDSTREAM + STATUS_EOF + STATUS_ERROR + )]); + + +use constant STATUS_OK => 0; +use constant STATUS_ENDSTREAM => 1; +use constant STATUS_EOF => 2; +use constant STATUS_ERROR => -1; +#use constant STATUS_OK => 0; +#use constant STATUS_ENDSTREAM => 1; +#use constant STATUS_ERROR => 2; +#use constant STATUS_EOF => 3; + +our ($needBinmode); +$needBinmode = ($^O eq 'MSWin32' || + ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} ')) + ? 1 : 1 ; + +sub setBinModeInput($) +{ + my $handle = shift ; + + binmode $handle + if $needBinmode; +} + +sub setBinModeOutput($) +{ + my $handle = shift ; + + binmode $handle + if $needBinmode; +} + +sub isaFilehandle($) +{ + use utf8; # Pragma needed to keep Perl 5.6.0 happy + return (defined $_[0] and + (UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa(\$_[0],'GLOB')) + and defined fileno($_[0]) ) +} + +sub isaFilename($) +{ + return (defined $_[0] and + ! ref $_[0] and + UNIVERSAL::isa(\$_[0], 'SCALAR')); +} + +sub isaFileGlobString +{ + return defined $_[0] && $_[0] =~ /^<.*>$/; +} + +sub cleanFileGlobString +{ + my $string = shift ; + + $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; + + return $string; +} + +use constant WANT_CODE => 1 ; +use constant WANT_EXT => 2 ; +use constant WANT_UNDEF => 4 ; +#use constant WANT_HASH => 8 ; +use constant WANT_HASH => 0 ; + +sub whatIsInput($;$) +{ + my $got = whatIs(@_); + + if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') + { + use IO::File; + $got = 'handle'; + #$_[0] = \*STDIN; + $_[0] = new IO::File("<-"); + } + + return $got; +} + +sub whatIsOutput($;$) +{ + my $got = whatIs(@_); + + if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') + { + $got = 'handle'; + #$_[0] = \*STDOUT; + $_[0] = new IO::File(">-"); + } + + return $got; +} + +sub whatIs ($;$) +{ + return 'handle' if isaFilehandle($_[0]); + + my $wantCode = defined $_[1] && $_[1] & WANT_CODE ; + my $extended = defined $_[1] && $_[1] & WANT_EXT ; + my $undef = defined $_[1] && $_[1] & WANT_UNDEF ; + my $hash = defined $_[1] && $_[1] & WANT_HASH ; + + return 'undef' if ! defined $_[0] && $undef ; + + if (ref $_[0]) { + return '' if blessed($_[0]); # is an object + #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object + return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR'); + return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ; + return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ; + return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ; + return ''; + } + + return 'fileglob' if $extended && isaFileGlobString($_[0]); + return 'filename'; +} + +sub oneTarget +{ + return $_[0] =~ /^(code|handle|buffer|filename)$/; +} + +sub Validator::new +{ + my $class = shift ; + + my $Class = shift ; + my $error_ref = shift ; + my $reportClass = shift ; + + my %data = (Class => $Class, + Error => $error_ref, + reportClass => $reportClass, + ) ; + + my $obj = bless \%data, $class ; + + local $Carp::CarpLevel = 1; + + my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH); + my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH); + + my $oneInput = $data{oneInput} = oneTarget($inType); + my $oneOutput = $data{oneOutput} = oneTarget($outType); + + if (! $inType) + { + $obj->croakError("$reportClass: illegal input parameter") ; + #return undef ; + } + +# if ($inType eq 'hash') +# { +# $obj->{Hash} = 1 ; +# $obj->{oneInput} = 1 ; +# return $obj->validateHash($_[0]); +# } + + if (! $outType) + { + $obj->croakError("$reportClass: illegal output parameter") ; + #return undef ; + } + + + if ($inType ne 'fileglob' && $outType eq 'fileglob') + { + $obj->croakError("Need input fileglob for outout fileglob"); + } + +# 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') + { + $data{GlobMap} = 1 ; + $data{inType} = $data{outType} = 'filename'; + my $mapper = new File::GlobMapper($_[0], $_[1]); + if ( ! $mapper ) + { + return $obj->saveErrorString($File::GlobMapper::Error) ; + } + $data{Pairs} = $mapper->getFileMap(); + + return $obj; + } + + $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' + { + my $glob = cleanFileGlobString($_[0]); + my @inputs = glob($glob); + + if (@inputs == 0) + { + # TODO -- legal or die? + die "globmap matched zero file -- legal or die???" ; + } + elsif (@inputs == 1) + { + $obj->validateInputFilenames($inputs[0]) + or return undef; + $_[0] = $inputs[0] ; + $data{inType} = 'filename' ; + $data{oneInput} = 1; + } + else + { + $obj->validateInputFilenames(@inputs) + or return undef; + $_[0] = [ @inputs ] ; + $data{inType} = 'filenames' ; + } + } + elsif ($inType eq 'filename') + { + $obj->validateInputFilenames($_[0]) + or return undef; + } + elsif ($inType eq 'array') + { + $data{inType} = 'filenames' ; + $obj->validateInputArray($_[0]) + or return undef ; + } + + return $obj->saveErrorString("$reportClass: output buffer is read-only") + if $outType eq 'buffer' && readonly(${ $_[1] }); + + if ($outType eq 'filename' ) + { + $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 +{ + my $self = shift ; + + foreach my $filename (@_) + { + $self->croakError("$self->{reportClass}: input filename is undef or null string") + if ! defined $filename || $filename eq '' ; + + next if $filename eq '-'; + + if (! -e $filename ) + { + return $self->saveErrorString("input file '$filename' does not exist"); + } + + if (! -r $filename ) + { + return $self->saveErrorString("cannot open file '$filename': $!"); + } + } + + return 1 ; +} + +sub Validator::validateInputArray +{ + my $self = shift ; + + if ( @{ $_[0] } == 0 ) + { + return $self->saveErrorString("empty array reference") ; + } + + foreach my $element ( @{ $_[0] } ) + { + my $inType = whatIsInput($element); + + if (! $inType) + { + $self->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 +#{ +# 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 $class = shift || (caller)[0] ; + my $error_ref = shift ; + + 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 $obj; +} + + + +#package Parse::Parameters ; +# +# +#require Exporter; +#our ($VERSION, @ISA, @EXPORT); +#$VERSION = '2.000_08'; +#@ISA = qw(Exporter); + +$EXPORT_TAGS{Parse} = [qw( ParseParameters + Parse_any Parse_unsigned Parse_signed + Parse_boolean Parse_custom Parse_string + Parse_store_ref + ) + ]; + +push @EXPORT, @{ $EXPORT_TAGS{Parse} } ; + +use constant Parse_any => 0x01; +use constant Parse_unsigned => 0x02; +use constant Parse_signed => 0x04; +use constant Parse_boolean => 0x08; +use constant Parse_string => 0x10; +use constant Parse_custom => 0x12; + +use constant Parse_store_ref => 0x100 ; + +use constant OFF_PARSED => 0 ; +use constant OFF_TYPE => 1 ; +use constant OFF_DEFAULT => 2 ; +use constant OFF_FIXED => 3 ; +use constant OFF_FIRST_ONLY => 4 ; +use constant OFF_STICKY => 5 ; + + + +sub ParseParameters +{ + my $level = shift || 0 ; + + my $sub = (caller($level + 1))[3] ; + local $Carp::CarpLevel = 1 ; + my $p = new IO::Compress::Base::Parameters() ; + $p->parse(@_) + or croak "$sub: $p->{Error}" ; + + return $p; +} + +#package IO::Compress::Base::Parameters; + +use strict; +use warnings; +use Carp; + +sub IO::Compress::Base::Parameters::new +{ + my $class = shift ; + + my $obj = { Error => '', + Got => {}, + } ; + + #return bless $obj, ref($class) || $class || __PACKAGE__ ; + return bless $obj, 'IO::Compress::Base::Parameters' ; +} + +sub IO::Compress::Base::Parameters::setError +{ + my $self = shift ; + my $error = shift ; + my $retval = @_ ? shift : undef ; + + $self->{Error} = $error ; + return $retval; +} + +#sub getError +#{ +# my $self = shift ; +# return $self->{Error} ; +#} + +sub IO::Compress::Base::Parameters::parse +{ + my $self = shift ; + + my $default = shift ; + + my $got = $self->{Got} ; + my $firstTime = keys %{ $got } == 0 ; + + my (@Bad) ; + my @entered = () ; + + # Allow the options to be passed as a hash reference or + # as the complete hash. + if (@_ == 0) { + @entered = () ; + } + elsif (@_ == 1) { + my $href = $_[0] ; + return $self->setError("Expected even number of parameters, got 1") + if ! defined $href or ! ref $href or ref $href ne "HASH" ; + + foreach my $key (keys %$href) { + push @entered, $key ; + push @entered, \$href->{$key} ; + } + } + else { + my $count = @_; + return $self->setError("Expected even number of parameters, got $count") + if $count % 2 != 0 ; + + for my $i (0.. $count / 2 - 1) { + push @entered, $_[2* $i] ; + push @entered, \$_[2* $i+1] ; + } + } + + + while (my ($key, $v) = each %$default) + { + 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 ; + + $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) { + my $key = $entered[2* $i] ; + my $value = $entered[2* $i+1] ; + + #print "Key [$key] Value [$value]" ; + #print defined $$value ? "[$$value]\n" : "[undef]\n"; + + $key =~ s/^-// ; + my $canonkey = lc $key; + + if ($got->{$canonkey} && ($firstTime || + ! $got->{$canonkey}[OFF_FIRST_ONLY] )) + { + 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->{$canonkey} = [1, $type, $value, $s] ; + } + else + { push (@Bad, $key) } + } + + if (@Bad) { + my ($bad) = join(", ", @Bad) ; + return $self->setError("unknown key value(s) @Bad") ; + } + + return 1; +} + +sub IO::Compress::Base::Parameters::_checkType +{ + my $self = shift ; + + my $key = shift ; + my $value = shift ; + my $type = shift ; + my $validate = shift ; + my $output = shift; + + #local $Carp::CarpLevel = $level ; + #print "PARSE $type $key $value $validate $sub\n" ; + if ( $type & Parse_store_ref) + { + #$value = $$value + # if ref ${ $value } ; + + $$output = $value ; + return 1; + } + + $value = $$value ; + + if ($type & Parse_any) + { + $$output = $value ; + return 1; + } + elsif ($type & Parse_unsigned) + { + return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'") + if $validate && ! defined $value ; + return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") + if $validate && $value !~ /^\d+$/; + + $$output = defined $value ? $value : 0 ; + return 1; + } + elsif ($type & Parse_signed) + { + return $self->setError("Parameter '$key' must be a signed int, got 'undef'") + if $validate && ! defined $value ; + return $self->setError("Parameter '$key' must be a signed int, got '$value'") + if $validate && $value !~ /^-?\d+$/; + + $$output = defined $value ? $value : 0 ; + return 1 ; + } + elsif ($type & Parse_boolean) + { + 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; + } + elsif ($type & Parse_string) + { + $$output = defined $value ? $value : "" ; + return 1; + } + + $$output = $value ; + return 1; +} + + + +sub IO::Compress::Base::Parameters::parsed +{ + my $self = shift ; + my $name = shift ; + + return $self->{Got}{lc $name}[OFF_PARSED] ; +} + +sub IO::Compress::Base::Parameters::value +{ + my $self = shift ; + my $name = shift ; + + if (@_) + { + $self->{Got}{lc $name}[OFF_PARSED] = 1; + $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ; + $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ; + } + + return $self->{Got}{lc $name}[OFF_FIXED] ; +} + +sub IO::Compress::Base::Parameters::valueOrDefault +{ + my $self = shift ; + my $name = shift ; + my $default = shift ; + + my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ; + + return $value if defined $value ; + return $default ; +} + +sub IO::Compress::Base::Parameters::wantValue +{ + my $self = shift ; + my $name = shift ; + + return defined $self->{Got}{lc $name}[OFF_DEFAULT] ; + +} + +sub IO::Compress::Base::Parameters::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, 'IO::Compress::Base::Parameters' ; +} + +package IO::Compress::Base::Common; + +1; diff --git a/ext/Compress/IO/Base/lib/IO/Uncompress/AnyUncompress.pm b/ext/Compress/IO/Base/lib/IO/Uncompress/AnyUncompress.pm new file mode 100644 index 0000000..a2c4df2 --- /dev/null +++ b/ext/Compress/IO/Base/lib/IO/Uncompress/AnyUncompress.pm @@ -0,0 +1,905 @@ +package IO::Uncompress::AnyUncompress ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::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 IO::Uncompress::Adapter::Bunzip2; import IO::Uncompress::Adapter::Bunzip2 }; + eval { require IO::Uncompress::Adapter::LZO; import IO::Uncompress::Adapter::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_08'; +$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) = IO::Uncompress::Adapter::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) = IO::Uncompress::Adapter::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) = IO::Uncompress::Adapter::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__ + + +=head1 NAME + + +IO::Uncompress::AnyUncompress - Perl interface to read 1950, 1951 & 1952 files/buffers + + +=head1 SYNOPSIS + + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + my $status = anyuncompress $input => $output [,OPTS] + or die "anyuncompress failed: $AnyUncompressError\n"; + + my $z = new IO::Uncompress::AnyUncompress $input [OPTS] + or die "anyuncompress failed: $AnyUncompressError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $z->trailingData() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $AnyUncompressError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + + +=head1 DESCRIPTION + + + +B. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + + + +This module provides a Perl interface that allows the reading of +any files/buffers. + +For writing 1950, 1951 & 1952 files/buffers, see the companion module IO::Compress::RawDeflate. + + + +=head1 Functional Interface + +A top-level function, C, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L +section. + + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + anyuncompress $input => $output [,OPTS] + or die "anyuncompress failed: $AnyUncompressError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 anyuncompress $input => $output [, OPTS] + + +C expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, 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 filenames before any data is uncompressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C will assume that it is an I. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L for more details. + + +=back + +If the C<$input> parameter is any other type, C will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +uncompressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the uncompressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the uncompressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C will assume that it is an I. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C will be returned. + + + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the uncompressed input files/buffers will all be stored +in C<$output> as a single uncompressed stream. + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C, +C, are the same as those used with the OO interface defined in the +L section below. + +=over 5 + +=item AutoClose =E 0|1 + +This option applies to any input or output data streams to +C that are filehandles. + +If C is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C has +completed. + +This parameter defaults to 0. + + + +=item BinModeOut =E 0|1 + +When writing to a file or filehandle, set C before writing to the +file. + +Defaults to 0. + + + + + +=item -Append =E 0|1 + +TODO + +=item -MultiStream =E 0|1 + +Creates a new stream after each file. + +Defaults to 1. + + + +=back + + + + +=head2 Examples + +To read the contents of the file C and write the +compressed data to the file C. + + use strict ; + use warnings ; + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + my $input = "file1.txt.Compressed"; + my $output = "file1.txt"; + anyuncompress $input => $output + or die "anyuncompress failed: $AnyUncompressError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + use IO::File ; + + my $input = new IO::File " \$buffer + or die "anyuncompress failed: $AnyUncompressError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.Compressed" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + anyuncompress '' => '' + or die "anyuncompress failed: $AnyUncompressError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + for my $input ( glob "/my/home/*.txt.Compressed" ) + { + my $output = $input; + $output =~ s/.Compressed// ; + anyuncompress $input => $output + or die "Error compressing '$input': $AnyUncompressError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::AnyUncompress is shown below + + + my $z = new IO::Uncompress::AnyUncompress $input [OPTS] + or die "IO::Uncompress::AnyUncompress failed: $AnyUncompressError\n"; + +Returns an C object on success and undef on failure. +The variable C<$AnyUncompressError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::AnyUncompress can be used exactly like an L filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$output>. + +=back + +=head2 Constructor Options + + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item -AutoClose =E 0|1 + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C method is called or the IO::Uncompress::AnyUncompress object is +destroyed. + +This parameter defaults to 0. + +=item -MultiStream =E 0|1 + + + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + + + +=item -Prime =E $string + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I with these bytes using this +option. + +=item -Transparent =E 0|1 + +If this option is set and the input file or buffer is not compressed data, +the module will allow reading of it anyway. + +This option defaults to 1. + +=item -BlockSize =E $num + +When reading the compressed input data, IO::Uncompress::AnyUncompress will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item -InputLength =E $size + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + + + +This option defaults to off. + +=item -Append =E 0|1 + +This option controls what the C method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C method. + +If set to 0, the contents of the output parameter of the C method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item -Strict =E 0|1 + + + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + + + + + + + + + + + + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size the the compressed block is +determined by the C option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C method and the +previous one, is that this one will attempt to return I C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of of the variable C<$/> +(or C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C is in use) to +determine what constitutes an end of line. Both paragraph mode and file +slurp mode are supported. + + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + + + + +=head2 getHeaderInfo + +Usage is + + $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). + + + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the end of the compressed input stream has been reached. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C. + +B that the special variable C<$|> B be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + + +Returns the current uncompressed line number. If C is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to to determine what constitutes a line +terminator. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::AnyUncompress object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C option has been enabled when the IO::Uncompress::AnyUncompress +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::AnyUncompress at present. + +=over 5 + +=item :all + +Imports C and C<$AnyUncompressError>. +Same as doing this + + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + +=back + +=head1 EXAMPLES + + + + +=head1 SEE ALSO + +L, L, L, L, L, L, L, L, L, L, L, L + +L + +L, L, +L, +L + + + + + + + + +=head1 AUTHOR + +The I module was written by Paul Marquess, +F. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005-2006 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/ext/Compress/IO/Base/lib/IO/Uncompress/Base.pm b/ext/Compress/IO/Base/lib/IO/Uncompress/Base.pm new file mode 100644 index 0000000..13b187a --- /dev/null +++ b/ext/Compress/IO/Base/lib/IO/Uncompress/Base.pm @@ -0,0 +1,1341 @@ + +package IO::Uncompress::Base ; + +use strict ; +use warnings; +use bytes; + +our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS); +#@ISA = qw(Exporter IO::File); +@ISA = qw(Exporter ); + + +$VERSION = '2.000_08'; + +use constant G_EOF => 0 ; +use constant G_ERR => -1 ; + +use IO::Compress::Base::Common; +#use Parse::Parameters ; + +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 : STATUS_OK) ; + + 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]; + local $.; + + 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 || IO::Compress::Base::Parameters::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(STATUS_OK) ; + *$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}; + *$self->{CompressedInputLengthDone} = 1; + 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->{CompressedInputLengthDone} || + $self->smartEof(), $outSize); +# (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; + my $trailer_size = *$self->{Info}{TrailerLength} ; + my $got = 0; + if (*$self->{Info}{TrailerLength}) + { + $got = $self->smartRead(\$trailer, $trailer_size) ; + } + + if ($got == $trailer_size) { + $self->chkTrailer($trailer) == STATUS_OK + or return G_ERR; + } + else { + return $self->TrailerError("trailer truncated. Expected " . + "$trailer_size bytes, got $got") + if *$self->{Strict}; + $self->pushBack($trailer) ; + } + + 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::Raw::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 ; + $. = ++ *$self->{LineNo} if defined($data); + 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 ; + $. = ++ *$self->{LineNo} ; + return \$par ; + } + } + $. = ++ *$self->{LineNo} if defined($paragraph); + 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}) { + local $.; + $! = 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 ; +} + +sub opened +{ + my $self = shift ; + return ! *$self->{Closed} ; +} + +sub autoflush +{ + my $self = shift ; + return defined *$self->{FH} + ? *$self->{FH}->autoflush(@_) + : undef ; +} + +sub input_line_number +{ + my $self = shift ; + my $last = *$self->{LineNo}; + $. = *$self->{LineNo} = $_[1] if @_ ; + return $last; +} + + +*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__ + +=head1 NAME + + +IO::Uncompress::Base - Base Class for IO::Uncompress modules + + +=head1 SYNOPSIS + + use IO::Uncompress::Base ; + +=head1 DESCRIPTION + + +This module is not intended for direct use in application code. Its sole +purpose if to to be sub-classed by IO::Unompress modules. + + + + +=head1 SEE ALSO + +L, L, L, L, L, L, L, L, L, L, L, L, L + +L + +L, L, +L, +L + + + + + + + + +=head1 AUTHOR + +The I module was written by Paul Marquess, +F. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005-2006 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + diff --git a/ext/Compress/IO/Base/private/MakeUtil.pm b/ext/Compress/IO/Base/private/MakeUtil.pm new file mode 100644 index 0000000..a2cce29 --- /dev/null +++ b/ext/Compress/IO/Base/private/MakeUtil.pm @@ -0,0 +1,287 @@ +package MakeUtil ; +package main ; + +use strict ; + +use Config qw(%Config); +use File::Copy; + + +BEGIN +{ + eval { require File::Spec::Functions ; File::Spec::Functions->import() } ; + if ($@) + { + *catfile = sub { return "$_[0]/$_[1]" } + } +} + +require VMS::Filespec if $^O eq 'VMS'; + + +unless($ENV{PERL_CORE}) { + $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV; +} + +$ENV{SKIP_FOR_CORE} = 1 if $ENV{PERL_CORE} || $ENV{MY_PERL_CORE} ; + + + +sub MY::libscan +{ + my $self = shift; + my $path = shift; + + return undef + if $path =~ /(~|\.bak|_bak)$/ || + $path =~ /\..*\.sw(o|p)$/ || + $path =~ /\B\.svn\b/; + + return $path; +} + +sub MY::postamble +{ + return '' + if $ENV{PERL_CORE} ; + + my @files = getPerlFiles('MANIFEST'); + + my $postamble = ' + +MyTrebleCheck: + @echo Checking for $$^W in files: '. "@files" . ' + @perl -ne \' \ + exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/; \ + \' ' . " @files || " . ' \ + (echo found unexpected $$^W ; exit 1) + @echo All is ok. + +'; + + return $postamble; +} + +sub getPerlFiles +{ + my @manifests = @_ ; + + my @files = (); + + for my $manifest (@manifests) + { + my $prefix = './'; + + $prefix = $1 + if $manifest =~ m#^(.*/)#; + + open M, "<$manifest" + or die "Cannot open '$manifest': $!\n"; + while () + { + chomp ; + next if /^\s*#/ || /^\s*$/ ; + + s/^\s+//; + s/\s+$//; + + /^(\S+)\s*(.*)$/; + + my ($file, $rest) = ($1, $2); + + if ($file =~ /\.(pm|pl|t)$/ and $file !~ /MakeUtil.pm/) + { + push @files, "$prefix$file"; + } + elsif ($rest =~ /perl/i) + { + push @files, "$prefix$file"; + } + + } + close M; + } + + return @files; +} + +sub UpDowngrade +{ + return if defined $ENV{TipTop}; + + my @files = @_ ; + + # our and use bytes/utf8 is stable from 5.6.0 onward + # warnings is stable from 5.6.1 onward + + # Note: this code assumes that each statement it modifies is not + # split across multiple lines. + + + my $warn_sub = ''; + my $our_sub = '' ; + + my $upgrade ; + my $downgrade ; + + my $caller = (caller(1))[3] || ''; + + if ($caller =~ /downgrade/) + { + $downgrade = 1; + } + elsif ($caller =~ /upgrade/) + { + $upgrade = 1; + } +# else +# { +# my $opt = shift @ARGV || '' ; +# $upgrade = ($opt =~ /^-upgrade/i); +# $downgrade = ($opt =~ /^-downgrade/i); +# push @ARGV, $opt unless $downgrade || $upgrade; +# } + + if ($downgrade) { + # From: use|no warnings "blah" + # To: local ($^W) = 1; # use|no warnings "blah" + $warn_sub = sub { + s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; + s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; + }; + } + elsif ($] >= 5.006001 || $upgrade) { + # From: local ($^W) = 1; # use|no warnings "blah" + # To: use|no warnings "blah" + $warn_sub = sub { + s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; + }; + } + + if ($downgrade) { + $our_sub = sub { + if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) { + my $indent = $1; + my $vars = join ' ', split /\s*,\s*/, $2; + $_ = "${indent}use vars qw($vars);\n"; + } + elsif ( /^(\s*)((use|no)\s+(bytes|utf8)\s*;.*)$/) + { + $_ = "$1# $2\n"; + } + }; + } + elsif ($] >= 5.006000 || $upgrade) { + $our_sub = sub { + if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) { + my $indent = $1; + my $vars = join ', ', split ' ', $2; + $_ = "${indent}our ($vars);\n"; + } + elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/) + { + $_ = "$1$2\n"; + } + }; + } + + if (! $our_sub && ! $warn_sub) { + warn "Up/Downgrade not needed.\n"; + if ($upgrade || $downgrade) + { exit 0 } + else + { return } + } + + foreach (@files) { + #if (-l $_ ) + { doUpDown($our_sub, $warn_sub, $_) } + #else + #{ doUpDownViaCopy($our_sub, $warn_sub, $_) } + } + + warn "Up/Downgrade complete.\n" ; + exit 0 if $upgrade || $downgrade; + +} + + +sub doUpDown +{ + my $our_sub = shift; + my $warn_sub = shift; + + return if -d $_[0]; + + local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak"; + local (@ARGV) = shift; + + while (<>) + { + print, last if /^__(END|DATA)__/ ; + + &{ $our_sub }() if $our_sub ; + &{ $warn_sub }() if $warn_sub ; + print ; + } + + return if eof ; + + while (<>) + { print } +} + +sub doUpDownViaCopy +{ + my $our_sub = shift; + my $warn_sub = shift; + my $file = shift ; + + use File::Copy ; + + return if -d $file ; + + my $backup = $file . ($^O eq 'VMS') ? "_bak" : ".bak"; + + copy($file, $backup) + or die "Cannot copy $file to $backup: $!"; + + my @keep = (); + + { + open F, "<$file" + or die "Cannot open $file: $!\n" ; + while () + { + if (/^__(END|DATA)__/) + { + push @keep, $_; + last ; + } + + &{ $our_sub }() if $our_sub ; + &{ $warn_sub }() if $warn_sub ; + push @keep, $_; + } + + if (! eof F) + { + while () + { push @keep, $_ } + } + close F; + } + + { + open F, ">$file" + or die "Cannot open $file: $!\n"; + print F @keep ; + close F; + } +} + +package MakeUtil ; + +1; + + diff --git a/ext/Compress/IO/Base/t/01misc.t b/ext/Compress/IO/Base/t/01misc.t new file mode 100644 index 0000000..dd8c1fb --- /dev/null +++ b/ext/Compress/IO/Base/t/01misc.t @@ -0,0 +1,121 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 29 + $extra ; + + + use_ok('IO::Compress::Base::Common'); + + #use_ok('Compress::Zlib::ParseParameters'); + +} + + +# Compress::Zlib::Common; + +sub My::testParseParameters() +{ + eval { ParseParameters(1, {}, 1) ; }; + like $@, mkErr(': Expected even number of parameters, got 1'), + "Trap odd number of params"; + + eval { ParseParameters(1, {}, undef) ; }; + like $@, mkErr(': Expected even number of parameters, got 1'), + "Trap odd number of params"; + + eval { ParseParameters(1, {}, []) ; }; + like $@, mkErr(': Expected even number of parameters, got 1'), + "Trap odd number of params"; + + eval { ParseParameters(1, {'Fred' => [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' => [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' => [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' => [1, 1, Parse_store_ref, 0]}, Fred => 'abc') ; + is ${ $got->value('Fred') }, "abc", "Parse_store_ref" ; + + $got = ParseParameters(1, {'Fred' => [1, 1, 0x1000000, 0]}, Fred => 'abc') ; + is $got->value('Fred'), "abc", "other" ; + +} + +My::testParseParameters(); + + +{ + title "isaFilename" ; + ok isaFilename("abc"), "'abc' isaFilename"; + + ok ! isaFilename(undef), "undef ! isaFilename"; + ok ! isaFilename([]), "[] ! isaFilename"; + $main::X = 1; $main::X = $main::X ; + ok ! isaFilename(*X), "glob ! isaFilename"; +} + +{ + title "whatIsInput" ; + + my $lex = new LexFile my $out_file ; + open FH, ">$out_file" ; + is whatIsInput(*FH), 'handle', "Match filehandle" ; + close FH ; + + my $stdin = '-'; + is whatIsInput($stdin), 'handle', "Match '-' as stdin"; + #is $stdin, \*STDIN, "'-' changed to *STDIN"; + #isa_ok $stdin, 'IO::File', "'-' changed to IO::File"; + is whatIsInput("abc"), 'filename', "Match filename"; + is whatIsInput(\"abc"), 'buffer', "Match buffer"; + is whatIsInput(sub { 1 }, 1), 'code', "Match code"; + is whatIsInput(sub { 1 }), '' , "Don't match code"; + +} + +{ + title "whatIsOutput" ; + + my $lex = new LexFile my $out_file ; + open FH, ">$out_file" ; + is whatIsOutput(*FH), 'handle', "Match filehandle" ; + close FH ; + + my $stdout = '-'; + is whatIsOutput($stdout), 'handle', "Match '-' as stdout"; + #is $stdout, \*STDOUT, "'-' changed to *STDOUT"; + #isa_ok $stdout, 'IO::File', "'-' changed to IO::File"; + is whatIsOutput("abc"), 'filename', "Match filename"; + is whatIsOutput(\"abc"), 'buffer', "Match buffer"; + is whatIsOutput(sub { 1 }, 1), 'code', "Match code"; + is whatIsOutput(sub { 1 }), '' , "Don't match code"; + +} diff --git a/ext/Compress/IO/Base/t/99pod.t b/ext/Compress/IO/Base/t/99pod.t new file mode 100644 index 0000000..760f737 --- /dev/null +++ b/ext/Compress/IO/Base/t/99pod.t @@ -0,0 +1,16 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use Test::More; + +eval "use Test::Pod 1.00"; + +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +all_pod_files_ok(); + diff --git a/ext/Compress/IO/Base/t/globmapper.t b/ext/Compress/IO/Base/t/globmapper.t new file mode 100644 index 0000000..10a4d88 --- /dev/null +++ b/ext/Compress/IO/Base/t/globmapper.t @@ -0,0 +1,304 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict ; +use warnings ; + +use Test::More ; +use CompTestUtils; + + +BEGIN +{ + plan(skip_all => "File::GlobMapper needs Perl 5.005 or better - you have +Perl $]" ) + if $] < 5.005 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 68 + $extra ; + + use_ok('File::GlobMapper') ; +} + +{ + title "Error Cases" ; + + my $gm; + + for my $delim ( qw/ ( ) { } [ ] / ) + { + $gm = new File::GlobMapper("${delim}abc", '*.X'); + ok ! $gm, " new failed" ; + is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", + " catch unmatched $delim"; + } + + for my $delim ( qw/ ( ) [ ] / ) + { + $gm = new File::GlobMapper("{${delim}abc}", '*.X'); + ok ! $gm, " new failed" ; + is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", + " catch unmatched $delim inside {}"; + } + + +} + +{ + title "input glob matches zero files"; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + + my $gm = new File::GlobMapper("$tmpDir/Z*", '*.X'); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 0, " returned 0 maps"; + is_deeply $map, [], " zero maps" ; + + my $hash = $gm->getHash() ; + is_deeply $hash, {}, " zero maps" ; +} + +{ + title 'test wildcard mapping of * in destination'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/ab*.tmp", "*X"); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmpX)], + [map { "$tmpDir/$_" } qw(abc2.tmp abc2.tmpX)], + [map { "$tmpDir/$_" } qw(abc3.tmp abc3.tmpX)], + ], " got mapping"; + + my $hash = $gm->getHash() ; + is_deeply $hash, + { map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmpX + abc2.tmp abc2.tmpX + abc3.tmp abc3.tmpX), + }, " got mapping"; +} + +{ + title 'no wildcards in input or destination'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/abc2.tmp", "$tmpDir/abc2.tmp"); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 1, " returned 1 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_.tmp" } qw(abc2 abc2)], + ], " got mapping"; + + my $hash = $gm->getHash() ; + is_deeply $hash, + { map { "$tmpDir/$_.tmp" } qw(abc2 abc2), + }, " got mapping"; +} + +{ + title 'test wildcard mapping of {} in destination'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "*.X"); + #diag "Input pattern is $gm->{InputPattern}"; + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 2, " returned 2 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmp.X)], + [map { "$tmpDir/$_" } qw(abc3.tmp abc3.tmp.X)], + ], " got mapping"; + + $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "$tmpDir/X.#1.X") + or diag $File::GlobMapper::Error ; + #diag "Input pattern is $gm->{InputPattern}"; + ok $gm, " created GlobMapper object" ; + + $map = $gm->getFileMap() ; + is @{ $map }, 2, " returned 2 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X.1.X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X.3.X)], + ], " got mapping"; + +} + + +{ + title 'test wildcard mapping of multiple * to #'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/*b(*).tmp", "$tmpDir/X-#2-#1-X"); + ok $gm, " created GlobMapper object" + or diag $File::GlobMapper::Error ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], + [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], + ], " got mapping"; +} + +{ + title 'test wildcard mapping of multiple ? to #'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/?b(*).tmp", "$tmpDir/X-#2-#1-X"); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], + [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], + ], " got mapping"; +} + +{ + title 'test wildcard mapping of multiple ?,* and [] to #'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("./$tmpDir/?b[a-z]*.tmp", "./$tmpDir/X-#3-#2-#1-X"); + ok $gm, " created GlobMapper object" ; + + #diag "Input pattern is $gm->{InputPattern}"; + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "./$tmpDir/$_" } qw(abc1.tmp X-1-c-a-X)], + [map { "./$tmpDir/$_" } qw(abc2.tmp X-2-c-a-X)], + [map { "./$tmpDir/$_" } qw(abc3.tmp X-3-c-a-X)], + ], " got mapping"; +} + +{ + title 'input glob matches a file multiple times'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch "$tmpDir/abc.tmp"; + + my $gm = new File::GlobMapper("$tmpDir/{a*,*c}.tmp", '*.X'); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 1, " returned 1 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc.tmp abc.tmp.X)], ], " got mapping"; + + my $hash = $gm->getHash() ; + is_deeply $hash, + { map { "$tmpDir/$_" } qw(abc.tmp abc.tmp.X) }, " got mapping"; + +} + +{ + title 'multiple input files map to one output file'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc def) ; + + my $gm = new File::GlobMapper("$tmpDir/*.tmp", "$tmpDir/fred"); + ok ! $gm, " did not create GlobMapper object" ; + + is $File::GlobMapper::Error, 'multiple input files map to one output file', " Error is expected" ; + + #my $map = $gm->getFileMap() ; + #is @{ $map }, 1, " returned 1 maps"; + #is_deeply $map, + #[ [map { "$tmpDir/$_" } qw(abc1 abc.X)], ], " got mapping"; +} + +{ + title "globmap" ; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $map = File::GlobMapper::globmap("$tmpDir/*b*.tmp", "$tmpDir/X-#2-#1-X"); + ok $map, " got map" + or diag $File::GlobMapper::Error ; + + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], + [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], + ], " got mapping"; +} + +# TODO +# test each of the wildcard metacharacters can be mapped to the output filename +# +# ~ [] {} . * + +# input & output glob with no wildcards is ok +# input with no wild or output with no wild is bad +# input wild has concatenated *'s +# empty string for either both from & to +# escaped chars within [] and {}, including the chars []{} +# escaped , within {} +# missing ] and missing } +# {} and {,} are special cases +# {ab*,de*} +# {abc,{},{de,f}} => abc {} de f + diff --git a/ext/Compress/IO/Zlib/Changes b/ext/Compress/IO/Zlib/Changes new file mode 100644 index 0000000..a677ed4 --- /dev/null +++ b/ext/Compress/IO/Zlib/Changes @@ -0,0 +1,11 @@ +CHANGES +------- + + 2.000_08 2 March 2006 + + * Split IO::Compress::Zlib into its own distribution. + + * Beefed up support for zip/unzip + + + diff --git a/ext/Compress/IO/Zlib/Makefile.PL b/ext/Compress/IO/Zlib/Makefile.PL new file mode 100644 index 0000000..027592a --- /dev/null +++ b/ext/Compress/IO/Zlib/Makefile.PL @@ -0,0 +1,42 @@ +#! perl -w + +use strict ; +require 5.004 ; + +use private::MakeUtil; +use ExtUtils::MakeMaker 5.16 ; + +UpDowngrade(getPerlFiles('MANIFEST')) + unless $ENV{PERL_CORE}; + +WriteMakefile( + NAME => 'IO::Compress::Zlib', + VERSION_FROM => 'lib/IO/Compress/Gzip.pm', + 'dist' => { COMPRESS => 'gzip', + TARFLAGS => '-chvf', + SUFFIX => 'gz', + DIST_DEFAULT => 'MyTrebleCheck tardist', + }, + + ( + $ENV{SKIP_FOR_CORE} + ? (MAN3PODS => {}) + : (PREREQ_PM => { 'Compress::Raw::Zlib' => 0, + 'IO::Compress::Base' => 0, + $] >= 5.005 && $] < 5.006 + ? ('File::BSDGlob' => 0) + : () } + ) + ), + + ( + $] >= 5.005 + ? (ABSTRACT => 'Perl interface to zlib', + AUTHOR => 'Paul Marquess ') + : () + ), + +) ; + +# end of file Makefile.PL + diff --git a/ext/Compress/IO/Zlib/README b/ext/Compress/IO/Zlib/README new file mode 100644 index 0000000..1413bc1 --- /dev/null +++ b/ext/Compress/IO/Zlib/README @@ -0,0 +1,163 @@ + + IO::Compress::Zlib + + Version 2.000_08 + + 27 Feb 2006 + + + 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. + + + + + WARNING + THIS IS BETA CODE. + + DO NOT use in production code. + Please report any problems. + +DESCRIPTION +----------- + + +This module provides a Perl interface to allow reading an writing of RFC +1950, 1951, 1952 (i.e. gzip) and zip files/buffers. + + + + + +PREREQUISITES +------------- + +Before you can build IO::Compress::Zlib you need to have the following +installed on your system: + + + * Perl 5.004 or better. + * Compress::Raw::Zlib + * IO::Compress::Base + + + + + +BUILDING THE MODULE +------------------- + +Assuming you have met all the prerequisites, the module can now be built +using this sequence of commands: + + perl Makefile.PL + make + make test + + + +INSTALLATION +------------ + +To install IO::Compress::Zlib, run the command below: + + make install + + + + + +TROUBLESHOOTING +--------------- + + + + + + + + + +The t/17isize Test Suite +------------------------ + +This test suite checks that IO::Compress::Zlib can cope with gzip files +that are larger than 2^32 bytes. + +By default these test are NOT run when you do a "make test". If you +really want to run them, you need to execute "make longtest". + +Be warned though -- this test suite can take hours to run on a slow box. + +Also, due to the way the tests are constructed, some architectures will +run out of memory during this test. This should not be considered a bug +in the IO::Compress::Zlib module. + + + + +FEEDBACK +-------- + +How to report a problem with IO::Compress::Zlib. + +To help me help you, I need all of the following information: + + 1. The Versions of everything relevant. + This includes: + + a. The *complete* output from running this + + perl -V + + Do not edit the output in any way. + Note, I want you to run "perl -V" and NOT "perl -v". + + If your perl does not understand the "-V" option it is too + old. This module needs Perl version 5.004 or better. + + b. The version of IO::Compress::Zlib you have. + If you have successfully installed IO::Compress::Zlib, this one-liner + will tell you: + + perl -MIO::Compress::Zlib -e 'print qq[ver $IO::Compress::Zlib::VERSION\n]' + + If you areplete* output from running this + + perl -V + + Do not edit the output in any way. + Note, I want you to run "perl -V" and NOT "perl -v". + + If your perl does not understand the "-V" option it is too + old. This module needs Perl version 5.004 or better. + + b. The version of IO::Compress::Zlib you have. + If you have successfully installed IO::Compress::Zlib, this one-liner + will tell you: + + perl -MIO::Compress::Zlib -e 'print qq[ver $IO::Compress::Zlib::VERSION\n]' + + If you are running windows use this + + perl -MIO::Compress::Zlib -e "print qq[ver $IO::Compress::Zlib::VERSION\n]" + + If you haven't installed IO::Compress::Zlib then search IO::Compress::Zlib.pm + for a line like this: + + $VERSION = "1.05" ; + + + + 2. If you are having problems building IO::Compress::Zlib, send me a + complete log of what happened. Start by unpacking the IO::Compress::Zlib + module into a fresh directory and keep a log of all the steps + + [edit config.in, if necessary] + perl Makefile.PL + make + make test TEST_VERBOSE=1 + + +Paul Marquess diff --git a/ext/Compress/IO/Zlib/examples/gzappend b/ext/Compress/IO/Zlib/examples/gzappend new file mode 100644 index 0000000..a4a60a9 --- /dev/null +++ b/ext/Compress/IO/Zlib/examples/gzappend @@ -0,0 +1,24 @@ +#!/usr/local/bin/perl + +use IO::Compress::Gzip qw( $GzipError ); +use strict ; +use warnings ; + +die "Usage: gzappend gz-file file...\n" + unless @ARGV ; + + +my $output = shift @ARGV ; + +@ARGV = '-' unless @ARGV ; + +my $gz = new IO::Compress::Gzip $output, Merge => 1 + or die "Cannot open $output: $GzipError\n" ; + +$gz->write( [@ARGV] ) + or die "Cannot open $output: $GzipError\n" ; + +$gz->close; + + + diff --git a/ext/Compress/IO/Zlib/examples/gzcat b/ext/Compress/IO/Zlib/examples/gzcat new file mode 100755 index 0000000..5572bae --- /dev/null +++ b/ext/Compress/IO/Zlib/examples/gzcat @@ -0,0 +1,29 @@ +#!/usr/local/bin/perl + +use IO::Uncompress::Gunzip qw( $GunzipError ); +use strict ; +use warnings ; + +#die "Usage: gzcat file...\n" +# unless @ARGV ; + +my $file ; +my $buffer ; +my $s; + +@ARGV = '-' unless @ARGV ; + +foreach $file (@ARGV) { + + my $gz = new IO::Uncompress::Gunzip $file + or die "Cannot open $file: $GunzipError\n" ; + + print $buffer + while ($s = $gz->read($buffer)) > 0 ; + + die "Error reading from $file: $GunzipError\n" + if $s < 0 ; + + $gz->close() ; +} + diff --git a/ext/Compress/IO/Zlib/examples/gzgrep b/ext/Compress/IO/Zlib/examples/gzgrep new file mode 100755 index 0000000..33820ba --- /dev/null +++ b/ext/Compress/IO/Zlib/examples/gzgrep @@ -0,0 +1,40 @@ +#!/usr/bin/perl + +use strict ; +use warnings ; +use IO::Uncompress::Gunzip qw($GunzipError); + +die "Usage: gzgrep pattern [file...]\n" + unless @ARGV >= 1; + +my $pattern = shift ; +my $file ; + +@ARGV = '-' unless @ARGV ; + +foreach $file (@ARGV) { + my $gz = new IO::Uncompress::Gunzip $file + or die "Cannot uncompress $file: $GunzipError\n" ; + + while (<$gz>) { + print if /$pattern/ ; + } + + die "Error reading from $file: $GunzipError\n" + if $GunzipError ; +} + +__END__ +foreach $file (@ARGV) { + my $gz = gzopen($file, "rb") + or die "Cannot open $file: $gzerrno\n" ; + + while ($gz->gzreadline($_) > 0) { + print if /$pattern/ ; + } + + die "Error reading from $file: $gzerrno\n" + if $gzerrno != Z_STREAM_END ; + + $gz->gzclose() ; +} diff --git a/ext/Compress/IO/Zlib/examples/gzstream b/ext/Compress/IO/Zlib/examples/gzstream new file mode 100755 index 0000000..9d03bc5 --- /dev/null +++ b/ext/Compress/IO/Zlib/examples/gzstream @@ -0,0 +1,24 @@ +#!/usr/local/bin/perl + +use strict ; +use warnings ; +use IO::Compress::Gzip qw(gzip $GzipError); + +gzip '-' => '-', Minimal => 1 + or die "gzstream: $GzipError\n" ; + +#exit 0; + +__END__ + +#my $gz = new IO::Compress::Gzip *STDOUT +my $gz = new IO::Compress::Gzip '-' + or die "gzstream: Cannot open stdout as gzip stream: $GzipError\n" ; + +while (<>) { + $gz->write($_) + or die "gzstream: Error writing gzip output stream: $GzipError\n" ; +} + +$gz->close + or die "gzstream: Error closing gzip output stream: $GzipError\n" ; diff --git a/ext/Compress/IO/Zlib/examples/unzip b/ext/Compress/IO/Zlib/examples/unzip new file mode 100644 index 0000000..417a9d2 --- /dev/null +++ b/ext/Compress/IO/Zlib/examples/unzip @@ -0,0 +1,69 @@ + +use strict; +use warnings; + +use IO::File; +use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError); + +die "Usage: zipcat file" + if @ARGV != 1 ; + +my $file = $ARGV[0] ; + +my $fh = new IO::File "<$file" + or die "Cannot open '$file': $!\n"; + +while () +{ + my $FIXED_HEADER_LENGTH = 30 ; + my $sig; + my $buffer; + + my $x ; + ($x = $fh->read($buffer, $FIXED_HEADER_LENGTH)) == $FIXED_HEADER_LENGTH + or die "Truncated file top: $x $!\n"; + + my $signature = unpack ("V", substr($buffer, 0, 4)); + + last unless $signature == 0x04034b50; + + my $compressedMethod = unpack ("v", substr($buffer, 8, 2)); + my $compressedLength = unpack ("V", substr($buffer, 18, 4)); + #my $uncompressedLength = unpack ("V", substr($buffer, 22, 4)); + my $filename_length = unpack ("v", substr($buffer, 26, 2)); + my $extra_length = unpack ("v", substr($buffer, 28, 2)); + + warn "Compressed Length $compressedLength\n"; + my $filename ; + $fh->read($filename, $filename_length) == $filename_length + or die "Truncated file\n"; + + $fh->read($buffer, $extra_length) == $extra_length + or die "Truncated file\n"; + + if ($compressedMethod != 8 && $compressedMethod != 0) + { + warn "Skipping file '$filename' - not deflated $compressedMethod\n"; + $fh->read($buffer, $compressedLength) == $compressedLength + or die "Truncated file\n"; + next; + } + + next if $compressedLength == 0; + + warn "Writing file '$filename' $compressedMethod\n"; + + mkpath basename $filename; + + rawinflate $fh => $filename, + Transparent => 1, + InputLength => $compressedLength + or die "Error uncompressing $file [$filename]: $RawInflateError\n" ; +} + +sub decodeLocalFileHeader +{ + my $buffer = shift ; +} + + diff --git a/ext/Compress/IO/Zlib/lib/IO/Compress/Adapter/Deflate.pm b/ext/Compress/IO/Zlib/lib/IO/Compress/Adapter/Deflate.pm new file mode 100644 index 0000000..63eb728 --- /dev/null +++ b/ext/Compress/IO/Zlib/lib/IO/Compress/Adapter/Deflate.pm @@ -0,0 +1,165 @@ +package IO::Compress::Adapter::Deflate ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common qw(:Status); + +use Compress::Raw::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::Raw::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, + '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) + if defined $def ; +} + +sub reset +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->deflateReset() ; + $self->{ErrorNo} = $status; + if ($status != Z_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + +sub deflateParams +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->deflateParams(@_); + $self->{ErrorNo} = $status; + if ($status != Z_OK) + { + $self->{Error} = "deflateParams Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + + + +#sub total_out +#{ +# my $self = shift ; +# $self->{Def}->total_out(); +#} +# +#sub total_in +#{ +# my $self = shift ; +# $self->{Def}->total_in(); +#} + +sub compressedBytes +{ + my $self = shift ; + + $self->{Def}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Def}->uncompressedBytes(); +} + + + + +sub crc32 +{ + my $self = shift ; + $self->{Def}->crc32(); +} + +sub adler32 +{ + my $self = shift ; + $self->{Def}->adler32(); +} + + +1; + +__END__ + diff --git a/ext/Compress/IO/Zlib/lib/IO/Compress/Adapter/Identity.pm b/ext/Compress/IO/Zlib/lib/IO/Compress/Adapter/Identity.pm new file mode 100644 index 0000000..9bea284 --- /dev/null +++ b/ext/Compress/IO/Zlib/lib/IO/Compress/Adapter/Identity.pm @@ -0,0 +1,127 @@ +package IO::Compress::Adapter::Identity ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common qw(:Status); +use Compress::Raw::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::Raw::Zlib::crc32(''), + 'wantADLER32'=> $adler32, + 'ADLER32' => Compress::Raw::Zlib::adler32(''), + } ; +} + +sub compr +{ + my $self = shift ; + + if (defined ${ $_[0] } && length ${ $_[0] }) { + $self->{CompSize} += length ${ $_[0] } ; + $self->{UnCompSize} = $self->{CompSize} ; + + $self->{CRC32} = Compress::Raw::Zlib::crc32($_[0], $self->{CRC32}) + if $self->{wantCRC32}; + + $self->{ADLER32} = Compress::Raw::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 ; + + $self->{CompSize} = 0; + $self->{UnCompSize} = 0; + $self->{CRC32} = Compress::Raw::Zlib::crc32(''); + $self->{ADLER32} = Compress::Raw::Zlib::adler32(''); + + return STATUS_OK; +} + +sub deflateParams +{ + my $self = shift ; + + return STATUS_OK; +} + +#sub total_out +#{ +# my $self = shift ; +# return $self->{UnCompSize} ; +#} +# +#sub total_in +#{ +# my $self = shift ; +# return $self->{UnCompSize} ; +#} + +sub compressedBytes +{ + my $self = shift ; + return $self->{UnCompSize} ; +} + +sub uncompressedBytes +{ + my $self = shift ; + return $self->{UnCompSize} ; +} + +sub crc32 +{ + my $self = shift ; + return $self->{CRC32}; +} + +sub adler32 +{ + my $self = shift ; + return $self->{ADLER32}; +} + + + +1; + + +__END__ + diff --git a/ext/Compress/IO/Zlib/lib/IO/Compress/Deflate.pm b/ext/Compress/IO/Zlib/lib/IO/Compress/Deflate.pm new file mode 100644 index 0000000..abcfee0 --- /dev/null +++ b/ext/Compress/IO/Zlib/lib/IO/Compress/Deflate.pm @@ -0,0 +1,1013 @@ +package IO::Compress::Deflate ; + +use strict ; +use warnings; +use bytes; + +require Exporter ; + +use IO::Compress::RawDeflate; + +use Compress::Raw::Zlib ; +use IO::Compress::Zlib::Constants; +use IO::Compress::Base::Common qw(createSelfTiedObject); + + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError); + +$VERSION = '2.000_08'; +$DeflateError = ''; + +@ISA = qw(Exporter IO::Compress::RawDeflate); +@EXPORT_OK = qw( $DeflateError deflate ) ; +%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, \$DeflateError); + return $obj->_create(undef, @_); +} + +sub deflate +{ + 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; + +__END__ + +=head1 NAME + + +IO::Compress::Deflate - Perl interface to write RFC 1950 files/buffers + + +=head1 SYNOPSIS + + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + + my $status = deflate $input => $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + my $z = new IO::Compress::Deflate $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $DeflateError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + + + +B. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1950. + + + + + + + + + +For reading RFC 1950 files/buffers, see the companion module +L. + + +=head1 Functional Interface + +A top-level function, C, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L +section. + + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + deflate $input => $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 deflate $input => $output [, OPTS] + + +C expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, 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 filenames before any data is compressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C will assume that it is an I. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L for more details. + + +=back + +If the C<$input> parameter is any other type, C will be returned. + + + +=head3 The C<$output> parameter + +The parameter C<$output> is used to control the destination of the +compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed +data will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data +will be written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be +stored in C<$$output>. + + + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> is a string that is delimited by the characters "<" and ">" +C will assume that it is an I. The +output is the list of files that match the fileglob. + +When C<$output> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C will be returned. + + + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the compressed input files/buffers will all be stored +in C<$output> as a single compressed stream. + + + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C, +C, are the same as those used with the OO interface defined in the +L section below. + +=over 5 + +=item AutoClose =E 0|1 + +This option applies to any input or output data streams to +C that are filehandles. + +If C is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C has +completed. + +This parameter defaults to 0. + + + +=item BinModeIn =E 0|1 + +When reading from a file or filehandle, set C before reading. + +Defaults to 0. + + + + + +=item -Append =E 0|1 + +TODO + + +=back + + + +=head2 Examples + +To read the contents of the file C and write the compressed +data to the file C. + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + my $input = "file1.txt"; + deflate $input => "$input.1950" + or die "deflate failed: $DeflateError\n"; + + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + use IO::File ; + + my $input = new IO::File " \$buffer + or die "deflate failed: $DeflateError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + deflate '' => '<*.1950>' + or die "deflate failed: $DeflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.1950" ; + deflate $input => $output + or die "Error compressing '$input': $DeflateError\n"; + } + + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C is shown below + + my $z = new IO::Compress::Deflate $output [,OPTS] + or die "IO::Compress::Deflate failed: $DeflateError\n"; + +It returns an C object on success and undef on failure. +The variable C<$DeflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Deflate can be used exactly like an L filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C::new will +return undef. + +=head2 Constructor Options + +C is any combination of the following options: + +=over 5 + +=item AutoClose =E 0|1 + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C method is called or the C +object is destroyed. + +This parameter defaults to 0. + +=item Append =E 0|1 + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C is enabled, all compressed data +will be append to the end if C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + + + + + +=item -Merge =E 0|1 + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + + + +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1950 data stream. + + + +There are a number of other limitations with the C option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A +fatal error will be thrown if C is used with an older version of +zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + + +This parameter defaults to 0. + + + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C by default. + + use IO::Compress::Deflate qw(:strategy); + use IO::Compress::Deflate qw(:constants); + use IO::Compress::Deflate qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + + + + + + +=item -Strict =E 0|1 + + + +This is a placeholder option. + + + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C if +unsuccessful. + +=head2 flush + +Usage is + + + $z->flush; + $z->flush($flush_type); + + +Flushes any pending compressed data to the output file/buffer. + + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C. Other valid values for C<$flush_type> are +C, C, C and C. It is +strongly recommended that you only set the C parameter if +you fully understand the implications of what it does - overuse of C +can seriously degrade the level of compression achieved. See the C +documentation for details. + + +Returns true on success. + + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + + + +Returns true if the C method has been called. + + + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + + + + +Provides a sub-set of the C functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + + + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C. + +B that the special variable C<$|> B be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + + +This method always returns C when compressing. + + + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, this method +will return the underlying file descriptor. + +If the C<$z> object is is associated with a buffer, this method will +return undef. + +=head2 close + + $z->close() ; + close $z ; + + + +Flushes any pending compressed data and then closes the output file/buffer. + + + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Deflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C option has been enabled when the IO::Compress::Deflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + + + + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +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 + + + +=back + + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + + +=head1 Importing + + +A number of symbolic constants are required by some methods in +C. None are imported by default. + + + +=over 5 + +=item :all + + +Imports C, C<$DeflateError> and all symbolic +constants that can be used by C. Same as doing this + + use IO::Compress::Deflate qw(deflate $DeflateError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + use IO::Compress::Deflate qw(:flush :level :strategy) ; + +=item :flush + +These symbolic constants are used by the C method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + +=item :level + +These symbolic constants are used by the C option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + + +=item :strategy + +These symbolic constants are used by the C option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + + +=back + +For + +=head1 EXAMPLES + +TODO + + + + + + +=head1 SEE ALSO + +L, L, L, L, L, L, L, L, L, L, L, L + +L + +L, L, +L, +L + + +For RFC 1950, 1951 and 1952 see +F, +F and +F + +The I compression library was written by Jean-loup Gailly +F and Mark Adler F. + +The primary site for the I compression library is +F. + +The primary site for gzip is F. + + + + + + + +=head1 AUTHOR + +The I module was written by Paul Marquess, +F. + + + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + + +Copyright (c) 2005-2006 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + diff --git a/ext/Compress/IO/Zlib/lib/IO/Compress/Gzip.pm b/ext/Compress/IO/Zlib/lib/IO/Compress/Gzip.pm new file mode 100644 index 0000000..0fc8519 --- /dev/null +++ b/ext/Compress/IO/Zlib/lib/IO/Compress/Gzip.pm @@ -0,0 +1,1490 @@ + +package IO::Compress::Gzip ; + +require 5.004 ; + +use strict ; +use warnings; +use bytes; + + +use IO::Compress::RawDeflate; + +use Compress::Raw::Zlib ; +use IO::Compress::Base::Common qw(:Status :Parse createSelfTiedObject); +use IO::Compress::Gzip::Constants; + +BEGIN +{ + if (defined &utf8::downgrade ) + { *noUTF8 = \&utf8::downgrade } + else + { *noUTF8 = sub {} } +} + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError); + +$VERSION = '2.000_08'; +$GzipError = '' ; + +@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 new +{ + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$GzipError); + + $obj->_create(undef, @_); +} + + +sub gzip +{ + my $obj = createSelfTiedObject(undef, \$GzipError); + return $obj->_def(@_); +} + +#sub newHeader +#{ +# my $self = shift ; +# #return GZIP_MINIMUM_HEADER ; +# return $self->mkHeader(*$self->{Got}); +#} + +sub getExtraParams +{ + my $self = shift ; + + return ( + # zlib behaviour + $self->getZlibParams(), + + # Gzip header fields + 'Minimal' => [0, 1, Parse_boolean, 0], + 'Comment' => [0, 1, Parse_any, undef], + 'Name' => [0, 1, Parse_any, undef], + 'Time' => [0, 1, Parse_any, undef], + 'TextFlag' => [0, 1, Parse_boolean, 0], + 'HeaderCRC' => [0, 1, Parse_boolean, 0], + 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code], + 'ExtraField'=> [0, 1, Parse_string, undef], + 'ExtraFlags'=> [0, 1, Parse_any, undef], + + ); +} + + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gzip always needs crc32 + $got->value('CRC32' => 1); + + return 1 + if $got->value('Merge') ; + + my $lax = ! $got->value('Strict') ; + + + { + if (! $got->parsed('Time') ) { + # Modification time defaults to now. + $got->value('Time' => time) ; + } + + # Check that the Name & Comment don't have embedded NULLs + # Also check that they only contain ISO 8859-1 chars. + if ($got->parsed('Name') && defined $got->value('Name')) { + my $name = $got->value('Name'); + + return $self->saveErrorString(undef, "Null Character found in Name", + Z_DATA_ERROR) + if ! $lax && $name =~ /\x00/ ; + + 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 $self->saveErrorString(undef, "Null Character found in Comment", + Z_DATA_ERROR) + if ! $lax && $comment =~ /\x00/ ; + + 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 $self->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'") + if $value < 0 || $value > 255 ; + + } + + # gzip only supports Deflate at present + $got->value('Method' => Z_DEFLATED) ; + + if ( ! $got->parsed('ExtraFlags')) { + $got->value('ExtraFlags' => 2) + if $got->value('Level') == Z_BEST_SPEED ; + $got->value('ExtraFlags' => 4) + if $got->value('Level') == Z_BEST_COMPRESSION ; + } + + if ($got->parsed('ExtraField')) { + + my $bad = $self->parseExtraField($got, $lax) ; + return $self->saveErrorString(undef, $bad, Z_DATA_ERROR) + if $bad ; + + my $len = length $got->value('ExtraField') ; + return $self->saveErrorString(undef, ExtraFieldError("Too Large"), + Z_DATA_ERROR) + if $len > GZIP_FEXTRA_MAX_SIZE; + } + } + + return 1; +} + +sub mkTrailer +{ + my $self = shift ; + return pack("V V", *$self->{Compress}->crc32(), + *$self->{UnCompSize_32bit}); +} + +sub getInverseClass +{ + return ('IO::Uncompress::Gunzip', + \$IO::Uncompress::Gunzip::GunzipError); +} + +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') ; +} + + +sub mkHeader +{ + my $self = shift ; + my $param = shift ; + + # stort-circuit if a minimal header is requested. + return GZIP_MINIMUM_HEADER if $param->value('Minimal') ; + + # METHOD + my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ; + + # FLAGS + my $flags = GZIP_FLG_DEFAULT ; + $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ; + $flags |= GZIP_FLG_FHCRC if $param->value('HeaderCRC') ; + $flags |= GZIP_FLG_FEXTRA if $param->wantValue('ExtraField') ; + $flags |= GZIP_FLG_FNAME if $param->wantValue('Name') ; + $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ; + + # MTIME + my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ; + + # EXTRA FLAGS + my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT); + + # OS CODE + my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ; + + + my $out = pack("C4 V C C", + GZIP_ID1, # ID1 + GZIP_ID2, # ID2 + $method, # Compression Method + $flags, # Flags + $time, # Modification Time + $extra_flags, # Extra Flags + $os_code, # Operating System Code + ) ; + + # EXTRA + if ($flags & GZIP_FLG_FEXTRA) { + my $extra = $param->value('ExtraField') ; + $out .= pack("v", length $extra) . $extra ; + } + + # NAME + if ($flags & GZIP_FLG_FNAME) { + my $name .= $param->value('Name') ; + $name =~ s/\x00.*$//; + $out .= $name ; + # Terminate the filename with NULL unless it already is + $out .= GZIP_NULL_BYTE + if !length $name or + substr($name, 1, -1) ne GZIP_NULL_BYTE ; + } + + # COMMENT + if ($flags & GZIP_FLG_FCOMMENT) { + my $comment .= $param->value('Comment') ; + $comment =~ s/\x00.*$//; + $out .= $comment ; + # Terminate the comment with NULL unless it already is + $out .= GZIP_NULL_BYTE + if ! length $comment or + substr($comment, 1, -1) ne GZIP_NULL_BYTE; + } + + # HEADER CRC + $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ; + + noUTF8($out); + + return $out ; +} + +sub ExtraFieldError +{ + return "Error with ExtraField Parameter: $_[0]" ; +} + +sub validateExtraFieldPair +{ + my $pair = shift ; + my $lax = shift ; + + return ExtraFieldError("Not an array ref") + unless ref $pair && ref $pair eq 'ARRAY'; + + return ExtraFieldError("SubField must have two parts") + unless @$pair == 2 ; + + return ExtraFieldError("SubField ID is a reference") + if ref $pair->[0] ; + + return ExtraFieldError("SubField Data is a reference") + if ref $pair->[1] ; + + # ID is exactly two chars + return ExtraFieldError("SubField ID not two chars long") + unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ; + + # Check that the 2nd byte of the ID isn't 0 + return ExtraFieldError("SubField ID 2nd byte is 0x00") + if ! $lax && substr($pair->[0], 1, 1) eq "\x00" ; + + return ExtraFieldError("SubField Data too long") + if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ; + + + return undef ; +} + +sub parseExtra +{ + my $data = shift ; + my $lax = shift ; + + return undef + if $lax ; + + my $XLEN = length $data ; + + return ExtraFieldError("Too Large") + if $XLEN > GZIP_FEXTRA_MAX_SIZE; + + my $offset = 0 ; + while ($offset < $XLEN) { + + return ExtraFieldError("FEXTRA Body") + if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; + + my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); + $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; + + my $subLen = unpack("v", substr($data, $offset, + GZIP_FEXTRA_SUBFIELD_LEN_SIZE)); + $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; + + return ExtraFieldError("FEXTRA Body") + if $offset + $subLen > $XLEN ; + + my $bad = validateExtraFieldPair( [$id, + substr($data, $offset, $subLen)], $lax ); + return $bad if $bad ; + + $offset += $subLen ; + } + + return undef ; +} + +sub parseExtraField +{ + my $self = shift ; + my $got = shift ; + my $lax = shift ; + + # ExtraField can be any of + # + # -ExtraField => $data + # -ExtraField => [$id1, $data1, + # $id2, $data2] + # ... + # ] + # -ExtraField => [ [$id1 => $data1], + # [$id2 => $data2], + # ... + # ] + # -ExtraField => { $id1 => $data1, + # $id2 => $data2, + # ... + # } + + + return undef + unless $got->parsed('ExtraField') ; + + return parseExtra($got->value('ExtraField'), $lax) + unless ref $got->value('ExtraField') ; + + my $data = $got->value('ExtraField'); + my $out = '' ; + + if (ref $data eq 'ARRAY') { + if (ref $data->[0]) { + + foreach my $pair (@$data) { + return ExtraFieldError("Not list of lists") + unless ref $pair eq 'ARRAY' ; + + my $bad = validateExtraFieldPair($pair, $lax) ; + return $bad if $bad ; + + $out .= $pair->[0] . pack("v", length $pair->[1]) . + $pair->[1] ; + } + } + else { + return ExtraFieldError("Not even number of elements") + unless @$data % 2 == 0; + + for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) { + my $bad = validateExtraFieldPair([$data->[$ix], $data->[$ix+1]], $lax) ; + return $bad if $bad ; + + $out .= $data->[$ix] . pack("v", length $data->[$ix+1]) . + $data->[$ix+1] ; + } + } + } + elsif (ref $data eq 'HASH') { + while (my ($id, $info) = each %$data) { + my $bad = validateExtraFieldPair([$id, $info], $lax); + return $bad if $bad ; + + $out .= $id . pack("v", length $info) . $info ; + } + } + else { + return ExtraFieldError("Not a scalar, array ref or hash ref") ; + } + + $got->value('ExtraField' => $out); + + return undef; +} + +sub mkFinalTrailer +{ + return ''; +} + +1; + +__END__ + +=head1 NAME + + +IO::Compress::Gzip - Perl interface to write RFC 1952 files/buffers + + +=head1 SYNOPSIS + + use IO::Compress::Gzip qw(gzip $GzipError) ; + + + my $status = gzip $input => $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + my $z = new IO::Compress::Gzip $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $GzipError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + + + +B. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + + + + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1952. + + + +All the gzip headers defined in RFC 1952 can be created using +this module. + + + + + + + +For reading RFC 1952 files/buffers, see the companion module +L. + + +=head1 Functional Interface + +A top-level function, C, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L +section. + + use IO::Compress::Gzip qw(gzip $GzipError) ; + + gzip $input => $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + + +The functional interface needs Perl5.005 or better. + + +=head2 gzip $input => $output [, OPTS] + + +C expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, is used to define the source of +the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the C<$input> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for reading and the input data +will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the input data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> is an array reference, 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 filenames before any data is compressed. + + + +=item An Input FileGlob string + +If C<$input> is a string that is delimited by the characters "<" and ">" +C will assume that it is an I. The +input is the list of files that match the fileglob. + +If the fileglob does not match any files ... + +See L for more details. + + +=back + +If the C<$input> parameter is any other type, C will be returned. + + + +In addition, if C<$input> is a simple filename, the default values for +a number of the gzip header fields created by this function will +be sourced from that file -- + +the NAME gzip header field will be populated with +the filename itself, and the MTIME header field will be set to the +modification time of the file. +The intention here is to mirror part of the behaviour of the gzip +executable. + +If you do not want to use these defaults they can be overridden by +explicitly setting the C and C