diff options
| author | Nicholas Clark <nick@ccl4.org> | 2009-10-02 11:11:19 +0100 |
|---|---|---|
| committer | Nicholas Clark <nick@ccl4.org> | 2009-10-02 11:11:19 +0100 |
| commit | 3fd969f44926f311e1c67d9470a9e936f7af2d73 (patch) | |
| tree | ce6e701f0f80bfd0de9befe7b1bf766e37a6cfbb /ext | |
| parent | 70b2007073159a8b94a74b0b9ba406945c45917d (diff) | |
| download | perl-3fd969f44926f311e1c67d9470a9e936f7af2d73.tar.gz | |
Move IO::Compress from ext/ to cpan/
Diffstat (limited to 'ext')
143 files changed, 0 insertions, 34592 deletions
diff --git a/ext/IO-Compress/Changes b/ext/IO-Compress/Changes deleted file mode 100644 index 6460a72849..0000000000 --- a/ext/IO-Compress/Changes +++ /dev/null @@ -1,874 +0,0 @@ -CHANGES -------- - - 2.021 30 August 2009 - - - * IO::Compress::Base.pm - - Less warnnings when reading from a closed filehandle. - [RT# 48350] - - Fixed minor typo in an error message. - [RT# 39719] - - * Makefile.PL - The PREREQ_PM dependency on Scalar::Util got dropped when - IO-Compress was created in 2.017. - [RT# 47509] - - * IO::Compress::Zip.pm - - Removed restriction that zip64 is only supported in streaming - mode. - - The "version made by" and "extract" fields in the zip64 end - central record were swapped. - - In the End Central Header record the "offset to the start of the - central directory" will now always be set to 0xFFFFFFFF when - zip64 is enabled. - - In the End Central Header record the "total entries in the - central directory" field will be set to 0xFFFF if zip64 is - enabled AND there are more than 0xFFFF entries present. - - * IO::Uncompress::Unzip.pm - - Don't consume lots of memory when walking a zip file. This makes - life more bearable when dealing with zip64. - - * Compress::Zlib.pm - - documented that memGunzip cannot cope with concatenated gzip data - streams. - - * Changed test harness so that it can cope with PERL5OPT=-MCarp=verbose - [RT# 47225] - - * IO::Compress::Gzip::Constants.pm - - GZIP_FEXTRA_MAX_SIZE was set to 0xFF. Should be 0xFFFF. This - issue came up when attempting to unzip a file created by MS - Office 2007. - - 2.020 3 June 2009 - - * IO::Uncompress::Base.pm - - Fixed problem with LimitOutput where a call to uncompress - created more uncompressed output, but didn't consume any of - the input buffer. The symptom is the underlying compression - library (zlib or bzip2) thinks the input stream is corrupt. - [RT #46582] - - 2.019 4 May 2009 - - * IO::Uncompress::Adapter::Bunzip2 - - Fixed problem with EOF check. - - 2.018 3 May 2009 - - * IO::Unompress::Bunzip2 - - The interface to Compress-Raw-Bzip2 now uses the new LimitOutput - feature. This will make all of the bzip2-related IO-Compress modules - less greedy in their memory consumption. - - * IO::Compress::Zip - - Fixed exTime & exUnix2 - - - Fixed 'Use of uninitialized value in pack' warning when using - ZIP_CM_STORE. - - 2.017 30 March 2009 - - * Merged IO-Compress-Base, IO-Compress-Bzip2, IO-Compress-Zlib & - Compress-Zlib into IO-Compress. - - * The interface to Compress-Raw-Zlib now uses the new LimitOutput - feature. This will make all of the zlib-related IO-Compress modules - less greedy in their memory consumption. - - * Removed MAN3PODS from Makefile.PL - - * A few changes to get the test harness to work on VMS courtesy of - Craig. A. Berry. - - * IO::Compress::Base & IO::Uncompress::Base - Downgraded some croaks in the constructors to just set $! (by letting - the code attempt to open a file and fail). - This makes the behavior more consistent to a standard open. - [RT #42657] - - * IO::Uncompress::Base - Doing a seek with MultiStream could drop some of the uncompressed - data. Fixed. - - * IO::Compress::Zip - - Fixed problem with the uncompressed & uncompressed fields when - zip64 is enabled. They were set to 0x0000FFFF instead of - 0xFFFFFFFF. Also the ZIP64 extra field was 4 bytes short. - Problem spotted by Dino Chiesa. - - * IO::Uncompress::Unzip - - use POSIX::mktime instead of Time::Local::timelocal to convert - the zip DOS time field into Unix time. - - * Compress::Zlib - - Documented Compress::Zlib::zlib_version() - - - 2.015 3 September 2008 - - * Makefile.PL - Backout changes made in 2.014 - - 2.014 2 September 2008 - - * Makefile.PL - Updated to check for indirect dependencies. - - 2.013 18 July 2008 - - * IO::Compress::Base - - Allow IO::Compress::Base::Parameters::parse to accept an - IO::Compress::Base::Parameters object. - - 2.012 15 July 2008 - - * IO::Compress::Base - - Silenced an uninitialised value warning when reading a line - at a time from a zip file where the content uses ZIP_CM_STORE. - [Problem spotted & fixed by Jeff Holt] - - * IO::Compress::Base & IO::Uncompress::Base - - local-ise $!, $? et al in the DESTROY methods. - - 2.011 17 May 2008 - - * IO::Compress::Base - - Fixed problem that prevented the creation of a zip file that - contained more than one compression method. - - * IO::Compress::Base::Common - - The private Validator class in this module clashes with another - CPAN module. Moved Validator into the IO::Compress::Base::Common - namespace. - [RT #35954] - - * IO::Uncompress::Unzip - - Print an error message if the zip file contains a - member compressed with bzip2 and IO::Uncompress::Bunzip2 is - not available. - - Could not cope with mixed compression zip files. For example a - zip file that contains both STORED and DEFLATED content. - [RT #35573] - - 2.010 5 May 2008 - - * Fixed problem that meant Perl 5.10 could not upgrade this module. - [RT #35342 & 35341] - - 2.009 20 April 2008 - - * Removed the alpha status from File::GlobMapper - - * IO::Compress::Base - When writing output never output a zero length buffer. - Done to improve interoperability with other tied filenandle - modules. - - * Changed IO::Uncompress::Base to not use the offset parameter of - the read method when reading from a filehandle. - - The object returned from Net::FTP::retr implements a non-standard - read method. The third parameter is used for a timeout value - rather than an offset. - [rt.cpan#33231] - - * Changed IO::Uncompress::Base to not use the eof method when - reading from a filehandle. - - The object returned from Net::FTP::retr implements both the read - method and the eof method. Unfortunately the implementation of - the read method uses non-buffered IO (by using sysread) while - the eof method uses buffered IO. Mixing buffered and non-buffered - IO results in data corruption. - - * IO::Compress::Zip - - - Added exUnix2 option to allow storing of UID & GID. - - When running on a Unix derivative the ExtAttr option now defaults - to the equivalent of 0666. For all other systems the default - remains 0. - - * Compress::Zlib - - Minor documentation issue with flush. - [rt.cpan.org #31446] - - - 2.008 2 November 2007 - - * Minor documentation changes in README - - * t/compress/truncate.pl - EBCDIC Cleanup. - - * IO::Compress::Gzip::Constants.pm - Tidied up the character classes used to defined invalid - FNAME & FCOMMENT fields for EBCDIC. - - * Compress::Zlib - lib/Compress/Zlib.pm -- 1.x Backward Compatability issues - gzclose - documented return value was wrong, should be 0 for ok. - gzflush - return value didn't match 1.x, should return 0 if ok. - [rt.cpan.org #29215] and Debian bug #440943 http://bugs.debian.org/440943 - - 2.006 1 September 20007 - - * Makefile.PL - Added INSTALLDIRS directive to install as a core module when built - on a perl >= 5.9. - - * IO::Uncompress::RawDeflate - - - Fixed export problem - "$RawDeflateError" and "rawdeflate" were - not being exported with ":all". - - * Compress::Zlib - - t/03zlib-v1.t - Fixed crc32 and adler32 tests in to remove ascii assumption. - - - lib/Compress/Zlib.pm - Make gzreadline not support $/, just like in Compress::Zlib 1.x - Folk who want $/ with readline support can get it in - IO::Uncompress::Gunzip. [rt.cpan.org #28663] and - Debian bug #435656 http://bugs.debian.org/435656 - - - 2.005 18 June 2007 - - * Stephen Turner reported a problem when using IO::Uncompress::Gunzip - with XML::Parser. Turns out there were two issues. - - Firstly an IO::Uncompress object isn't an IO::Handle. It is now. - - Secondly the implementation of "read" wasn't honouring this - - SCALAR will be grown or shrunk to the length actually read. - - In particular it didn't do the right thing on EOF. - This has been fixed. - - * IO::Compress::Gzip & IO::Uncompress::Gunzip - - - RFC1952 says that the FNAME & FCOMMENT header fields must be ISO - 8859-1 (LATIN-1) characters. The code can optionally police this. - Added a fix for this logic when running on EBCDIC. - - * Compress::Zlib - Added info about removing Compress::Zlib version 1, before - installing version 2. - - 2.004 3 March 2007 - - * Made seek less wasteful of memory. - - * IO::Compress::Zip - - - Added Zip64 documentation. - - - Fixed extended timestamp. - Creation time isn't available in Unix so only store the - modification time and the last access time in the extended field. - - - Fixed file mode. - - - Added ExtAttr option to control the value of the "external file - attributes" field in the central directory. - - - Added Unix2 extended attribute ("Ux"). - This stores the UID & GID. - - * IO::Compress::Gzip - - - Fixed 050interop-gzip.t for Windows - - * IO::Compress::Bzip2 - - - Fixed 050interop-bzip2.t for Windows - - * Compress::Zlib - - - rewrote memGzip using IO::Compress::Gzip::gzip - - 2.003 2 January 2007 - - * Added explicit version checking - - 2.002 29 December 2006 - - * Documentation updates. - - * Added IO::Handle to the ISA test in isaFilehandle - - * Add an explicit use_ok test for Scalar::Util in the test harness. - The error message reported by 01misc implied the problem was - somewhere else. - Also explictly check that 'dualvar' is available. - - * Compress::Zlib - - Fix append mode with gzopen. - rt-cpan.org 24041 - - - Allow gzopen to read from and write to a scalar reference. - - 2.001 1 November 2006 - - * Remove beta status. - - 2.000_14 26 October 2006 - - * IO::Uncompress::Base - Added support for $/ in record mode - - * IO::Uncompress::Base - The readline interface was substantially slower than the 1.x - equivalent. This has now been sorted. - Thanks to Andreas J. Koenig for spotting the problem. - - * IO::Uncompress::AnyUncompress - Added IO::Uncompress::Lzf to the list of supported uncompresors. - - * IO::Uncompress::Base - Added TrailingData to one-shot interface. - - * IO::Uncompress::AnyUncompress - Remove raw-deflate (RFC1951) from the default list of compressors - to check. - It can still be included if the new RawInflate parameter is - supplied. - This change was made because the only way to tell if content is - raw-deflate is to attempt to uncompress it - a few false positives - have popped up recently, which suggests that auto-detecting raw - deflate is far from perfect. - The equivalent change has been made to IO::Uncompress::AnyInflate. - [Core patch #28445] - - * Don't check that filehandles are writable. It would seem that - "-w *STDOUT" on windows returns false. - [Core Patch #28415] - - * IO::Uncompress::Deflate - Beefed up the magic signature check. Means less false positives - when auto-detecting the compression type. - - * IO::Uncompress::UnZip - Tighten up the zip64 extra field processing to cope with the case - wheere only some of the local header fields are superceeded. - - * IO::Uncompress::AnyInflate - Remove raw-deflate (RFC 1951) from the default list of compressors - to check. - It can still be included if the new RawInflate parameter is - supplied. - This change was made because the only way to tell if content is - raw-deflate is to attempt to uncompress it - a few false positives - have popped up recently, which suggests that auto-detecting raw - deflate is far from perfect. - The equivalent change has been made to IO::Uncompress::AnyUncompress. - [Core patch #28445] - - 2.000_13 20 June 2006 - - * Store compress & uncompressed sizes as 64-bit. - - * For one-shot uncompression, like this - - unzip "some.zip" => \@a, MultiStream => 1; - - Push each uncompressed stream from "some.zip" onto @a. - - * Added IO::Compress::Base::FilterEnvelope - - * Added IO::Uncompress::Base::nextStream - - * The '-' filehandle now maps to either *STDIN or *STDOUT. - This keeps mod_perl happier. Was using these before - - new IO::File("<-") - new IO::File(">-") - - * Preliminary support for reading zip files with zip64 members. - - 2.000_12 3 May 2006 - - * Moved the code for creating and parsing the gzip extra field into - IO::Compress::Zlib::Extra.pm so that IO::Compress::Zip & - IO::Uncompress::Unzip can use it as well. - - * Added ExtraFieldLocal & ExtraFieldCentral options to IO::Compress::Zip. - These allow the creation of user-defined extra fields in the local - and central headers, just like the ExtraField option in - IO::Compress::Gzip. - - * Moved the zip constants into IO::Compress::Zip::Constants - - * Added exTime option to IO::Compress::Zip. - This allows creation of the extended timestamp extra field. - - * Added Minimal option to IO::Compress::Zip. - This disables the creation of all extended fields. - - * Added TextFlag option to IO::Compress::Zip. - - * Documented Comment and ZipComment options in IO::Compress::Zip. - - * Compress::Zlib - Fixed gzread to zap the output buffer to an empty string when zero - bytes are requested. This matches the behaviour of C::Z 1.x - - 2.000_11 10 April 2006 - - * Transparent + InputLength made more robust where input data is not - compressed. - - * Updated Documentation for zip modules. - - * Changed IO::Compress::Zip 'Store' option to 'Method' and added - symbolic constants ZIP_CM_STORE, ZIP_CM_DEFLATE and ZIP_CM_BZIP2 to - allow the compression method to be picked by the user. - - * Added support to allow bzip2 compressed data to be written/read - with IO::Compress::Zip and IO::Uncompress::Unzip. - - * Beefed up 050interop-gzip.t to check that the external gzip command - works as expected before starting the tests. This means that - this test harness will just be skipped on problematic systems. - - * Merged core patch 27565 from Steve Peters. This works around a - problem with gzip on OpenBSD where it doesn't seem to like - compressing files < 10 bytes long. - - * Beefed up 050interop-bzip2.t to check that the external bzip2 command - works as expected before starting the tests. This means that - this test harness will just be skipped on problematic systems. - - 2.000_10 13 March 2006 - - * AnyUncompress doesn't assume that IO-Compress-Zlib is installed any - more. - - * Documentation updates. - - * Compress::Zlib - Changed gzread so that its behaviour matches C::Z::gzread 1.x if it - is called after eof. In this case it will write an empty string - into the output parameter. This change is solely for backward - compatability reasons. - - 2.000_09 3 March 2006 - - * Released to CPAN. - - 2.000_08 2 March 2006 - - * Split IO::Compress::Base into its own distribution. - - * Split IO::Compress::Bzip2 into its own distribution. - - * Added opened, autoflush and input_line_number. - - * Beefed up support for $. - - * Split IO::Compress::Zlib into its own distribution. - - * Beefed up support for zip/unzip - - * Breakout zlib specific code into separate modules. - - * Limited support for reading/writing zip files - - 2.000_06 5 October 2005 - - * Added eof parameter to Compress::Zlib::inflate method. - - * Fixed issue with 64-bit - - 2.000_05 4 October 2005 - - * Renamed IO::* to IO::Compress::* & IO::Uncompress::* - - 2.000_04 23 September 2005 - - * Fixed some more non-portable test that were failing on VMS. - - * fixed problem where error messages in the oneshot interface were - getting lost. - - 2.000_03 12 September 2005 - - * Fixed some non-portable test that were failing on VMS. - - * Fixed export of zlib constants from the IO::* classes - - 2.000_02 6 September 2005 - - * Split Append mode into Append and Merge - - * Fixed typos in the documentation. - - * Added pod/FAQ.pod - - * Added libscan to Makefile.PL - - * Added InputLength for IO::Gunzip et al - - 2.000_01 22 August 2005 - - * Fixed VERSION in Compress::Gzip::Constants - - * Removed Compress::Gzip::Info from the distribution. - - 2.000_00 21 August 2005 - - * First Beta relase of Compress::zlib rewrite. - -Compress-Zlib version 1 Changes - - 1.38 - 6 September 2005 - - * Integrate core change 25304 -- Symbian Update - - * Added libscan to Makefile.PL - - 1.37 - 12 August 2005 - - * Change to t/03examples.t for VMS from Abe Timmerman - - 1.36 - 3 August 2005 - - * Renamed zlib-src-1.2.3 to zlib-src to help VMS - - * Fixed Makefile.PL for VMS - - * Fixed t/03examples.t for VMS - - * Added a couple of notes about incompatibility with Unix compress. - - 1.35 - 16 July 2005 - - * Updated zlib source to 1.2.3 - - * Fixed problem with where two calls to gzclose would hang the debugger. - See https://rt.cpan.org/Ticket/Display.html?id=13789 - - * Added code from Alexey Tourbin to use XSLoader when available, - and DynaLoader otherwise. - - * Documented that the compress & uncompress functions were not - the same as the Unix utilities of the same name. - - * Fixed 05gzsetp -- it left a temp file hanging around. - - * Integrate core change 24787 - SvUPGRADE returns void in blead - - * Integrate core change 24788 - Makefile.PL adjustments for the core - - - 1.34 - 30 January 2005 - - * Fixed typo in the README - - * Fixed examples.t on Win32 where paths have embedded whitespace. - - * Fix for Cygwin and core integration from Jos I. Boumans - - * Upgrade zlib source to 1.2.2 - - 1.33 - 14 January 2004 - - * Reworked Makefile.PL to avoid creating a private copy of zlib. - This both simplifies the build, plus it makes life easier for VMS. - - * Patches for Makefile.PL to get it to work on VMS supplied by - Craig A. Berry. - - * memGunzip has very slow on FreeBSD. Turns out to be down to - the way realloc works on FreeBSD. Changed both inflate & deflate - to use exponentially increasing buffer sizes when they need to - realloc. Thanks to Peter Jeremy for the lowdown on FreeBSD - memory allocation. - - 1.32 - 26 November 2003 - - * Steve Hay reported a problem on rt.cpan.org with Windows and - MSCV++ 6.0 where the source from the zlib directory was getting - installed with the rest of the module. - https://rt.cpan.org/Ticket/Display.html?id=1741 - - This has been fixed by renaming the "zlib" directory to "zlib-src" - thus avoiding a conflict with the name of this Perl module. - - * Fixed a bug in the inflate method where the input buffer is an - lvalue (via substr). Problem & solution reported by Salvador Fandiqo. - - * Tightened up the logic in Makefile.PL when BUILD_ZLIB is - True. Issue spotted by Ralf S. Engelschall. - - 1.31 - 29 October 2003 - - * Reinstated the creation of .bak files - $^I seems to need a - backup file on Windows. For OpenVMS, the extenstion _bak is used. - - 1.30 - 28 October 2003 - - * Bundled a sub-set of the zlib source with the module and changed - the default make behaviour to build with the included zlib source. - The previous behaviour of using a pre-built zlib library is - still available for those that want it. - - * Added prototypes to the subs in Zlib.pm that didn't already have - them. Patch from Ed Avis. - - * No .bak files are created by Makefile.PL any more - this keep - distclean much happier. Patch suggested by Ed Avis. - This also fixes a similar problem reported by Dr. Martin Zinser - on OpenVMS. - - * Documentation for some of the gz functions updated. - - * Format strings modified in DispStream to keep OpenVMS happy. - Problem reported by Dr. Martin Zinser. - - - 1.22 - 17 June 2003 - - * Makefile.PL now displays a warning about not installing - Compress::Zlib via the CPAN shell. - - * Fix to allow intermingling of gzread & gzreadline - patch - supplied by Doug Perham. - - * memGunzip will silently now work if the gzip trailer is - missing. Some HTTP Origin Servers seem to leave it out. - - 1.21 - 28 April 2003 - - * Tests 148 & 150 from t/02zlib.t were failing on redhat 9. - - * Added a few words about the problems with Mac OS X to the README file. - - 1.20 - 4 April 2003 - - * Fixed bug in gzopen where $gzerrno wasn't being set correctly. - The symptom was $gzerrno was set to Z_MEM_ERROR although the file - was opened ok. If gzopen failed, $gzerrno was being set correctly. - This problem wasn't spotted before because the typical test - to determine whether gzopen passed or failed was to check its - return value. - - 1.19 - 31 October 2002 - - * fixed a problem with t/02zlib.t that was failing with redhat 8. - - 1.18 - 24 October 2002 - - * fixed a Win32 problem in t/02zlib.t by changing sysread to read. - - * zlib 1.0.5 & older doesn't have gzsetparams & gzeof. Added a new - variable to config.in to flag an old version of zlib. Split - out the tests for gzsetparams into t/05gzsetp.t - - 1.17 - 23 May 2002 - - * Moved the test to check the versions of libz & zlib.h into a separate - file and added troubleshooting notes to README. - - * In gzopen, only attempt to call "tell" for normal files. - - * Fixed to work in taint mode. - - * Broke changes out of README into Changes file. - - * Replaced internal use of Z_PARTIAL_FLUSH symbol with Z_SYNC_FLUSH. - zlib.h says /* will be removed, use Z_SYNC_FLUSH instead */ - - 1.16 - 13 December 2001 - - * Fixed bug in Makefile.PL that stopped "perl Makefile.PL PREFIX=..." - working. - - 1.15 - 4th December 2001 - - * Changes a few types to get the module to build on 64-bit Solaris - - * Changed the up/downgrade logic to default to the older constructs, and - to only call a downgrade if specifically requested. Some older versions - of Perl were having problems with the in-place edit. - - * added the new XS constant code. - - 1.14 - 27th August 2001 - - * Memory overwrite bug fixed in "inflate". Kudos to Rob Simons for - reporting the bug and to Anton Berezin for fixing it for me. - - 1.13 - 31st June 2001 - - * Make sure config.in is consistant when released. - - 1.12 - 28th April 2001 - - * Modified Makefile.PL to only enable the warnings pragma if - using perl 5.6.1 or better. - - 1.11 - 17th February 2001 - - * Added logic in Makefile.PL to toggle between using $^W and - the warnings pragma in the module. - - * The module, the examples & the test harness are now all strict - & warnings clean. - - 1.10 - 5th February 2001 - - * fixed a bug in memGunzip. Used Z_ERR instead of Z_DATA_ERROR. - - 1.09 - 15th January 2001 - - * Silenced a few compiler warnings. - - * Updated zlib home site in README & Zlib.pm to www.info-zip.org - - * Minor typo in Zlib.pm - a link used AUTHORS instead of AUTHOR - -- spotted by Frank Martini. - - * Mention Archive::Zip - - * added memGunzip. This is largely based on code provided by Jim Leonard. - - * $deflate->flush can now take an optional parameter. Valid - values are Z_NO_FLUSH, Z_PARTIAL_FLUSH, Z_SYNC_FLUSH, Z_FULL_FLUSH - and Z_FINISH. The default is Z_FINISH. - - 1.08 - 6 Jan 2000 - - * uncompress was clobbering its input parameter. Now it doesn't. - This bug was spotted by Deven T. Corzine. - - * If a variable that only ever contained a number was given - to compress or deflate, it would not be compressed properly. Now - it will be coerced to a string and then compressed. This bug - was spotted by Deven T. Corzine. - - 1.07 - 27 Nov 1999 - - * ANSI-ified the static functions in Zlib.xs - - * Added the ability to build zlib along with the module. - This feature is 90% based on a Makefile provided by Gurusamy - Sarathy. - - 1.06 - 20 Sep 1999 - - * Fixed a nasty problem where inflate could truncate the data - returned. Thanks to Douglas Thomson <dougt@mugc.cc.monash.edu.au> - for both spotting the problem and fixing the bug. - - * Added a note about the undocumented features in zlib that are - required when accessing zip files. - - * gzclose will now get called automatically when the gzip object is - destroyed. - - 1.05 - 3 June 1999 - - * Previous release used newSVpvn, which doesn't exist in 5.004_04 - or earlier. Changed to use newSVpv instead. - - * The module needs Perl 5.004 or better, so updated the version - checking in Zlib.pm and Makefile.PL - - 1.04 - 27 May 1999 - - * Bug 19990527.001: compress(undef) core dumps -- Fixed. - - 1.03 - 17 Mar 1999 - - * Updated to use the new PL_ symbols. - Means the module can be built with Perl 5.005_5* - - 1.02 - 31 Jan 1999 - - * The return codes for gzread, gzreadline and gzwrite were - documented incorrectly as returning a status code. - - * The test harness was missing a "gzclose". This caused problem - showed up on an amiga. Thanks to Erik van Roode for reporting - this one. - - * Patched zlib.t for OS/2. Thanks to Ilya Zakharevich for the patch. - - 1.01 - 23 Nov 1997 - - * A number of fixes to the test suite and the example scripts to - allow them to work under win32. All courtesy of Gurusamy - Sarathy. - - 1.00 - 14 Nov 1997 - - * Fixed crc32 & adler32. They were very broken. - - * The following functions can now take a scalar reference in - place of a scalar for their buffer parameters: - - compress - uncompress - deflate - inflate - crc32 - adler32 - - This should mean applications that make use of the module don't - have to copy large buffers around. - - - * Normally the inflate method consumes I<all> of the input buffer - before returning. The exception to this is when inflate detects - the end of the stream (Z_STREAM_END). In this case the input - buffer need not be completely consumed. To allow processing of - file formats that embed a deflation stream (e.g. zip, gzip), - the inflate method now sets the buffer parameter to be what - remains after inflation. - - When the return status is Z_STREAM_END, it will be what remains - of the buffer (if any) after deflation. When the status is Z_OK - it will be an empty string. - - This change means that the buffer parameter must be a lvalue. - - * Fixed crc32 and adler32. They were both very broken. - - * Added the Compress::Zlib::memGzip function. - - 0.5 - Confirmed that no changes were necessary for zlib 1.0.3, or 1.0.4. - - The optional parameters for deflateInit and inflateInit can now - be specified as an associative array in addition to a reference - to an associative array. They can also accept the -Name - syntax. - - gzopen can now optionally take a reference to an open - filehandle in place of a filename. In this case it will call - gzdopen. - - Added gzstream example script. - - 0.4 - Upgrade to support zlib 0.99 - - Added dictionary interface. - - Fixed bug in gzreadline - previously it would keep returning - the same buffer. This bug was reported by Helmut Jarausch - - Removed dependency to zutil.h and so dropped support for - - DEF_MEM_LEVEL (use MAX_MEM_LEVEL instead) - DEF_WBITS (use MAX_WBITS instead) - - 0.3 - Added prototype specification. - - 0.2 - Fixed a minor allocation problem in Zlib.xs - - 0.1 - first alpha release. 2nd October 1995 diff --git a/ext/IO-Compress/Makefile.PL b/ext/IO-Compress/Makefile.PL deleted file mode 100644 index 64cdd29dac..0000000000 --- a/ext/IO-Compress/Makefile.PL +++ /dev/null @@ -1,56 +0,0 @@ -#! perl -w - -use strict ; -require 5.004 ; - -$::VERSION = '2.021' ; - -use private::MakeUtil; -use ExtUtils::MakeMaker 5.16 ; - -UpDowngrade(getPerlFiles('MANIFEST')) - unless $ENV{PERL_CORE}; - -WriteMakefile( - NAME => 'IO::Compress', - VERSION_FROM => 'lib/IO/Compress/Base.pm', - 'dist' => { COMPRESS => 'gzip', - TARFLAGS => '-chvf', - SUFFIX => 'gz', - DIST_DEFAULT => 'MyTrebleCheck tardist', - }, - - ( - $ENV{SKIP_FOR_CORE} - ? () - : (PREREQ_PM => { 'Compress::Raw::Bzip2' => $::VERSION, - 'Compress::Raw::Zlib' => $::VERSION, - 'Scalar::Util' => 0, - $] >= 5.005 && $] < 5.006 - ? ('File::BSDGlob' => 0) - : () } - ) - ), - - ( - $] >= 5.005 - ? (ABSTRACT => 'IO Interface to compressed data files/buffers', - AUTHOR => 'Paul Marquess <pmqs@cpan.org>') - : () - ), - - INSTALLDIRS => ($] >= 5.009 ? 'perl' : 'site'), - - ( - $] >= 5.009 && ! $ENV{PERL_CORE} - ? (INST_LIB => 'blib/arch') - : () - ), - - ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? - ('LICENSE' => 'perl') : ()), - -) ; - -# end of file Makefile.PL - diff --git a/ext/IO-Compress/README b/ext/IO-Compress/README deleted file mode 100644 index 67cc0c6ed4..0000000000 --- a/ext/IO-Compress/README +++ /dev/null @@ -1,103 +0,0 @@ - - IO-Compress - - Version 2.021 - - 30th August 2009 - - Copyright (c) 1995-2009 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. - -DESCRIPTION ------------ - -This distribution provides a Perl interface to allow reading and writing of -compressed data created with the zlib and bzip2 libraries. - -IO-Compress supports reading and writing of bzip2, RFC 1950, RFC -1951, RFC 1952 (i.e. gzip) and zip files/buffers. - -The following modules used to be distributed separately, but are now -included with the IO-Compress distribution. - - Compress-Zlib - IO-Compress-Zlib - IO-Compress-Bzip2 - IO-Compress-Base - -PREREQUISITES -------------- - -Before you can build IO-Compress you need to have the following -installed on your system: - - * Perl 5.004 or better. - * Compress::Raw::Zlib - * Compress::Raw::Bzip2 - -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, run the command below: - - make install - -TROUBLESHOOTING ---------------- - -FEEDBACK --------- - -How to report a problem with IO-Compress. - -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 you have. - If you have successfully installed IO-Compress, this one-liner - will tell you: - - perl -MIO::Compress::Gzip -e 'print qq[ver $IO::Compress::Gzip::VERSION\n]' - - If you are running windows use this - - perl -MIO::Compress::Gzip -e "print qq[ver $IO::Compress::Gzip::VERSION\n]" - - If you haven't installed IO-Compress then search IO::Compress::Gzip.pm - for a line like this: - - $VERSION = "2.021" ; - - 2. If you are having problems building IO-Compress, send me a - complete log of what happened. Start by unpacking the IO-Compress - 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 <pmqs@cpan.org> diff --git a/ext/IO-Compress/examples/compress-zlib/filtdef b/ext/IO-Compress/examples/compress-zlib/filtdef deleted file mode 100755 index 57dfeb9068..0000000000 --- a/ext/IO-Compress/examples/compress-zlib/filtdef +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/local/bin/perl - -use strict ; -use warnings ; - -use Compress::Zlib ; - -binmode STDIN; -binmode STDOUT; -my $x = deflateInit() - or die "Cannot create a deflation stream\n" ; - -my ($output, $status) ; -while (<>) -{ - ($output, $status) = $x->deflate($_) ; - - $status == Z_OK - or die "deflation failed\n" ; - - print $output ; -} - -($output, $status) = $x->flush() ; - -$status == Z_OK - or die "deflation failed\n" ; - -print $output ; diff --git a/ext/IO-Compress/examples/compress-zlib/filtinf b/ext/IO-Compress/examples/compress-zlib/filtinf deleted file mode 100755 index 1df202b1d7..0000000000 --- a/ext/IO-Compress/examples/compress-zlib/filtinf +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/local/bin/perl - -use strict ; -use warnings ; - -use Compress::Zlib ; - -my $x = inflateInit() - or die "Cannot create a inflation stream\n" ; - -my $input = '' ; -binmode STDIN; -binmode STDOUT; - -my ($output, $status) ; -while (read(STDIN, $input, 4096)) -{ - ($output, $status) = $x->inflate(\$input) ; - - print $output - if $status == Z_OK or $status == Z_STREAM_END ; - - last if $status != Z_OK ; -} - -die "inflation failed\n" - unless $status == Z_STREAM_END ; - diff --git a/ext/IO-Compress/examples/compress-zlib/gzcat b/ext/IO-Compress/examples/compress-zlib/gzcat deleted file mode 100755 index 5241a5a11f..0000000000 --- a/ext/IO-Compress/examples/compress-zlib/gzcat +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/local/bin/perl - -use strict ; -use warnings ; - -use Compress::Zlib ; - -#die "Usage: gzcat file...\n" -# unless @ARGV ; - -my $filename ; - -@ARGV = '-' unless @ARGV ; - -foreach my $filename (@ARGV) { - my $buffer ; - - my $gz = gzopen($filename, "rb") - or die "Cannot open $filename: $gzerrno\n" ; - - print $buffer while $gz->gzread($buffer) > 0 ; - - die "Error reading from $filename: $gzerrno" . ($gzerrno+0) . "\n" - if $gzerrno != Z_STREAM_END ; - - $gz->gzclose() ; -} diff --git a/ext/IO-Compress/examples/compress-zlib/gzgrep b/ext/IO-Compress/examples/compress-zlib/gzgrep deleted file mode 100755 index 324d3e615f..0000000000 --- a/ext/IO-Compress/examples/compress-zlib/gzgrep +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/local/bin/perl - -use strict ; -use warnings ; - -use Compress::Zlib ; - -die "Usage: gzgrep pattern file...\n" - unless @ARGV >= 2; - -my $pattern = shift ; - -my $file ; - -foreach $file (@ARGV) { - my $gz = gzopen($file, "rb") - or die "Cannot open $file: $gzerrno\n" ; - - 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/IO-Compress/examples/compress-zlib/gzstream b/ext/IO-Compress/examples/compress-zlib/gzstream deleted file mode 100755 index faacb0a0dd..0000000000 --- a/ext/IO-Compress/examples/compress-zlib/gzstream +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/local/bin/perl - -use strict ; -use warnings ; - -use Compress::Zlib ; - -binmode STDOUT; # gzopen only sets it on the fd - -#my $gz = gzopen(\*STDOUT, "wb") -my $gz = gzopen('-', "wb") - or die "Cannot open stdout: $gzerrno\n" ; - -while (<>) { - $gz->gzwrite($_) - or die "error writing: $gzerrno\n" ; -} - -$gz->gzclose ; diff --git a/ext/IO-Compress/examples/io/anycat b/ext/IO-Compress/examples/io/anycat deleted file mode 100755 index 9db9c41faf..0000000000 --- a/ext/IO-Compress/examples/io/anycat +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/local/bin/perl - -use strict ; -use warnings ; - -use IO::Uncompress::AnyInflate qw( anyinflate $AnyInflateError ); - -@ARGV = '-' unless @ARGV ; - -foreach my $file (@ARGV) { - - anyinflate $file => '-', - Transparent => 1, - Strict => 0, - or die "Cannot uncompress '$file': $AnyInflateError\n" ; - -} diff --git a/ext/IO-Compress/examples/io/bzip2/bzcat b/ext/IO-Compress/examples/io/bzip2/bzcat deleted file mode 100755 index 81123200c5..0000000000 --- a/ext/IO-Compress/examples/io/bzip2/bzcat +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/local/bin/perl - -use IO::Uncompress::Bunzip2 qw( $Bunzip2Error ); -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::Bunzip2 $file - or die "Cannot open $file: $Bunzip2Error\n" ; - - print $buffer - while ($s = $gz->read($buffer)) > 0 ; - - die "Error reading from $file: $Bunzip2Error\n" - if $s < 0 ; - - $gz->close() ; -} - diff --git a/ext/IO-Compress/examples/io/bzip2/bzgrep b/ext/IO-Compress/examples/io/bzip2/bzgrep deleted file mode 100755 index ceb4e8412b..0000000000 --- a/ext/IO-Compress/examples/io/bzip2/bzgrep +++ /dev/null @@ -1,25 +0,0 @@ -#!/usr/bin/perl - -use strict ; -use warnings ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error); - -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::Bunzip2 $file - or die "Cannot uncompress $file: $Bunzip2Error\n" ; - - while (<$gz>) { - print if /$pattern/ ; - } - - die "Error reading from $file: $Bunzip2Error\n" - if $Bunzip2Error ; -} diff --git a/ext/IO-Compress/examples/io/bzip2/bzstream b/ext/IO-Compress/examples/io/bzip2/bzstream deleted file mode 100755 index 3e88d68258..0000000000 --- a/ext/IO-Compress/examples/io/bzip2/bzstream +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/local/bin/perl - -use strict ; -use warnings ; -use IO::Compress::Bzip2 qw(:all); - -bzip2 '-' => '-' - or die "bzstream: $Bzip2Error\n" ; - diff --git a/ext/IO-Compress/examples/io/gzip/gzappend b/ext/IO-Compress/examples/io/gzip/gzappend deleted file mode 100644 index a4a60a9aad..0000000000 --- a/ext/IO-Compress/examples/io/gzip/gzappend +++ /dev/null @@ -1,24 +0,0 @@ -#!/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/IO-Compress/examples/io/gzip/gzcat b/ext/IO-Compress/examples/io/gzip/gzcat deleted file mode 100755 index 5572bae959..0000000000 --- a/ext/IO-Compress/examples/io/gzip/gzcat +++ /dev/null @@ -1,29 +0,0 @@ -#!/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/IO-Compress/examples/io/gzip/gzgrep b/ext/IO-Compress/examples/io/gzip/gzgrep deleted file mode 100755 index 33820ba064..0000000000 --- a/ext/IO-Compress/examples/io/gzip/gzgrep +++ /dev/null @@ -1,40 +0,0 @@ -#!/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/IO-Compress/examples/io/gzip/gzstream b/ext/IO-Compress/examples/io/gzip/gzstream deleted file mode 100755 index 9d03bc5749..0000000000 --- a/ext/IO-Compress/examples/io/gzip/gzstream +++ /dev/null @@ -1,24 +0,0 @@ -#!/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/IO-Compress/lib/Compress/Zlib.pm b/ext/IO-Compress/lib/Compress/Zlib.pm deleted file mode 100644 index 0a611039b8..0000000000 --- a/ext/IO-Compress/lib/Compress/Zlib.pm +++ /dev/null @@ -1,1461 +0,0 @@ - -package Compress::Zlib; - -require 5.004 ; -require Exporter; -use AutoLoader; -use Carp ; -use IO::Handle ; -use Scalar::Util qw(dualvar); - -use IO::Compress::Base::Common 2.021 ; -use Compress::Raw::Zlib 2.021 ; -use IO::Compress::Gzip 2.021 ; -use IO::Uncompress::Gunzip 2.021 ; - -use strict ; -use warnings ; -use bytes ; -our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD); - -$VERSION = '2.021'; -$XS_VERSION = $VERSION; -$VERSION = eval $VERSION; - -@ISA = qw(Exporter); -# Items to export into callers namespace by default. Note: do not export -# names by default without a very good reason. Use EXPORT_OK instead. -# Do not simply export all your public functions/methods/constants. -@EXPORT = qw( - deflateInit inflateInit - - compress uncompress - - gzopen $gzerrno - ); - -push @EXPORT, @Compress::Raw::Zlib::EXPORT ; - -BEGIN -{ - *zlib_version = \&Compress::Raw::Zlib::zlib_version; -} - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - my ($error, $val) = Compress::Raw::Zlib::constant($constname); - Carp::croak $error if $error; - no strict 'refs'; - *{$AUTOLOAD} = sub { $val }; - goto &{$AUTOLOAD}; -} - -use constant FLAG_APPEND => 1 ; -use constant FLAG_CRC => 2 ; -use constant FLAG_ADLER => 4 ; -use constant FLAG_CONSUME_INPUT => 8 ; - -our (@my_z_errmsg); - -@my_z_errmsg = ( - "need dictionary", # Z_NEED_DICT 2 - "stream end", # Z_STREAM_END 1 - "", # Z_OK 0 - "file error", # Z_ERRNO (-1) - "stream error", # Z_STREAM_ERROR (-2) - "data error", # Z_DATA_ERROR (-3) - "insufficient memory", # Z_MEM_ERROR (-4) - "buffer error", # Z_BUF_ERROR (-5) - "incompatible version",# Z_VERSION_ERROR(-6) - ); - - -sub _set_gzerr -{ - my $value = shift ; - - if ($value == 0) { - $Compress::Zlib::gzerrno = 0 ; - } - elsif ($value == Z_ERRNO() || $value > 2) { - $Compress::Zlib::gzerrno = $! ; - } - else { - $Compress::Zlib::gzerrno = dualvar($value+0, $my_z_errmsg[2 - $value]); - } - - return $value ; -} - -sub _save_gzerr -{ - my $gz = shift ; - my $test_eof = shift ; - - my $value = $gz->errorNo() || 0 ; - - if ($test_eof) { - #my $gz = $self->[0] ; - # gzread uses Z_STREAM_END to denote a successful end - $value = Z_STREAM_END() if $gz->eof() && $value == 0 ; - } - - _set_gzerr($value) ; -} - -sub gzopen($$) -{ - my ($file, $mode) = @_ ; - - my $gz ; - my %defOpts = (Level => Z_DEFAULT_COMPRESSION(), - Strategy => Z_DEFAULT_STRATEGY(), - ); - - my $writing ; - $writing = ! ($mode =~ /r/i) ; - $writing = ($mode =~ /[wa]/i) ; - - $defOpts{Level} = $1 if $mode =~ /(\d)/; - $defOpts{Strategy} = Z_FILTERED() if $mode =~ /f/i; - $defOpts{Strategy} = Z_HUFFMAN_ONLY() if $mode =~ /h/i; - $defOpts{Append} = 1 if $mode =~ /a/i; - - my $infDef = $writing ? 'deflate' : 'inflate'; - my @params = () ; - - croak "gzopen: file parameter is not a filehandle or filename" - unless isaFilehandle $file || isaFilename $file || - (ref $file && ref $file eq 'SCALAR'); - - return undef unless $mode =~ /[rwa]/i ; - - _set_gzerr(0) ; - - if ($writing) { - $gz = new IO::Compress::Gzip($file, Minimal => 1, AutoClose => 1, - %defOpts) - or $Compress::Zlib::gzerrno = $IO::Compress::Gzip::GzipError; - } - else { - $gz = new IO::Uncompress::Gunzip($file, - Transparent => 1, - Append => 0, - AutoClose => 1, - MultiStream => 1, - Strict => 0) - or $Compress::Zlib::gzerrno = $IO::Uncompress::Gunzip::GunzipError; - } - - return undef - if ! defined $gz ; - - bless [$gz, $infDef], 'Compress::Zlib::gzFile'; -} - -sub Compress::Zlib::gzFile::gzread -{ - my $self = shift ; - - return _set_gzerr(Z_STREAM_ERROR()) - if $self->[1] ne 'inflate'; - - my $len = defined $_[1] ? $_[1] : 4096 ; - - if ($self->gzeof() || $len == 0) { - # Zap the output buffer to match ver 1 behaviour. - $_[0] = "" ; - return 0 ; - } - - my $gz = $self->[0] ; - my $status = $gz->read($_[0], $len) ; - _save_gzerr($gz, 1); - return $status ; -} - -sub Compress::Zlib::gzFile::gzreadline -{ - my $self = shift ; - - my $gz = $self->[0] ; - { - # Maintain backward compatibility with 1.x behaviour - # It didn't support $/, so this can't either. - local $/ = "\n" ; - $_[0] = $gz->getline() ; - } - _save_gzerr($gz, 1); - return defined $_[0] ? length $_[0] : 0 ; -} - -sub Compress::Zlib::gzFile::gzwrite -{ - my $self = shift ; - my $gz = $self->[0] ; - - return _set_gzerr(Z_STREAM_ERROR()) - if $self->[1] ne 'deflate'; - - $] >= 5.008 and (utf8::downgrade($_[0], 1) - or croak "Wide character in gzwrite"); - - my $status = $gz->write($_[0]) ; - _save_gzerr($gz); - return $status ; -} - -sub Compress::Zlib::gzFile::gztell -{ - my $self = shift ; - my $gz = $self->[0] ; - my $status = $gz->tell() ; - _save_gzerr($gz); - return $status ; -} - -sub Compress::Zlib::gzFile::gzseek -{ - my $self = shift ; - my $offset = shift ; - my $whence = shift ; - - my $gz = $self->[0] ; - my $status ; - eval { $status = $gz->seek($offset, $whence) ; }; - if ($@) - { - my $error = $@; - $error =~ s/^.*: /gzseek: /; - $error =~ s/ at .* line \d+\s*$//; - croak $error; - } - _save_gzerr($gz); - return $status ; -} - -sub Compress::Zlib::gzFile::gzflush -{ - my $self = shift ; - my $f = shift ; - - my $gz = $self->[0] ; - my $status = $gz->flush($f) ; - my $err = _save_gzerr($gz); - return $status ? 0 : $err; -} - -sub Compress::Zlib::gzFile::gzclose -{ - my $self = shift ; - my $gz = $self->[0] ; - - my $status = $gz->close() ; - my $err = _save_gzerr($gz); - return $status ? 0 : $err; -} - -sub Compress::Zlib::gzFile::gzeof -{ - my $self = shift ; - my $gz = $self->[0] ; - - return 0 - if $self->[1] ne 'inflate'; - - my $status = $gz->eof() ; - _save_gzerr($gz); - return $status ; -} - -sub Compress::Zlib::gzFile::gzsetparams -{ - my $self = shift ; - croak "Usage: Compress::Zlib::gzFile::gzsetparams(file, level, strategy)" - unless @_ eq 2 ; - - my $gz = $self->[0] ; - my $level = shift ; - my $strategy = shift; - - return _set_gzerr(Z_STREAM_ERROR()) - if $self->[1] ne 'deflate'; - - my $status = *$gz->{Compress}->deflateParams(-Level => $level, - -Strategy => $strategy); - _save_gzerr($gz); - return $status ; -} - -sub Compress::Zlib::gzFile::gzerror -{ - my $self = shift ; - my $gz = $self->[0] ; - - return $Compress::Zlib::gzerrno ; -} - - -sub compress($;$) -{ - my ($x, $output, $err, $in) =('', '', '', '') ; - - if (ref $_[0] ) { - $in = $_[0] ; - croak "not a scalar reference" unless ref $in eq 'SCALAR' ; - } - else { - $in = \$_[0] ; - } - - $] >= 5.008 and (utf8::downgrade($$in, 1) - or croak "Wide character in compress"); - - my $level = (@_ == 2 ? $_[1] : Z_DEFAULT_COMPRESSION() ); - - $x = new Compress::Raw::Zlib::Deflate -AppendOutput => 1, -Level => $level - or return undef ; - - $err = $x->deflate($in, $output) ; - return undef unless $err == Z_OK() ; - - $err = $x->flush($output) ; - return undef unless $err == Z_OK() ; - - return $output ; - -} - -sub uncompress($) -{ - my ($x, $output, $err, $in) =('', '', '', '') ; - - if (ref $_[0] ) { - $in = $_[0] ; - croak "not a scalar reference" unless ref $in eq 'SCALAR' ; - } - else { - $in = \$_[0] ; - } - - $] >= 5.008 and (utf8::downgrade($$in, 1) - or croak "Wide character in uncompress"); - - $x = new Compress::Raw::Zlib::Inflate -ConsumeInput => 0 or return undef ; - - $err = $x->inflate($in, $output) ; - return undef unless $err == Z_STREAM_END() ; - - return $output ; -} - - - -sub deflateInit(@) -{ - my ($got) = ParseParameters(0, - { - 'Bufsize' => [1, 1, Parse_unsigned, 4096], - 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()], - 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()], - 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()], - 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()], - 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()], - 'Dictionary' => [1, 1, Parse_any, ""], - }, @_ ) ; - - croak "Compress::Zlib::deflateInit: Bufsize must be >= 1, you specified " . - $got->value('Bufsize') - unless $got->value('Bufsize') >= 1; - - my $obj ; - - my $status = 0 ; - ($obj, $status) = - Compress::Raw::Zlib::_deflateInit(0, - $got->value('Level'), - $got->value('Method'), - $got->value('WindowBits'), - $got->value('MemLevel'), - $got->value('Strategy'), - $got->value('Bufsize'), - $got->value('Dictionary')) ; - - my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldDeflate" : undef) ; - return wantarray ? ($x, $status) : $x ; -} - -sub inflateInit(@) -{ - my ($got) = ParseParameters(0, - { - 'Bufsize' => [1, 1, Parse_unsigned, 4096], - 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()], - 'Dictionary' => [1, 1, Parse_any, ""], - }, @_) ; - - - croak "Compress::Zlib::inflateInit: Bufsize must be >= 1, you specified " . - $got->value('Bufsize') - unless $got->value('Bufsize') >= 1; - - my $status = 0 ; - my $obj ; - ($obj, $status) = Compress::Raw::Zlib::_inflateInit(FLAG_CONSUME_INPUT, - $got->value('WindowBits'), - $got->value('Bufsize'), - $got->value('Dictionary')) ; - - my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldInflate" : undef) ; - - wantarray ? ($x, $status) : $x ; -} - -package Zlib::OldDeflate ; - -our (@ISA); -@ISA = qw(Compress::Raw::Zlib::deflateStream); - - -sub deflate -{ - my $self = shift ; - my $output ; - - my $status = $self->SUPER::deflate($_[0], $output) ; - wantarray ? ($output, $status) : $output ; -} - -sub flush -{ - my $self = shift ; - my $output ; - my $flag = shift || Compress::Zlib::Z_FINISH(); - my $status = $self->SUPER::flush($output, $flag) ; - - wantarray ? ($output, $status) : $output ; -} - -package Zlib::OldInflate ; - -our (@ISA); -@ISA = qw(Compress::Raw::Zlib::inflateStream); - -sub inflate -{ - my $self = shift ; - my $output ; - my $status = $self->SUPER::inflate($_[0], $output) ; - wantarray ? ($output, $status) : $output ; -} - -package Compress::Zlib ; - -use IO::Compress::Gzip::Constants 2.021 ; - -sub memGzip($) -{ - my $out; - - # if the deflation buffer isn't a reference, make it one - my $string = (ref $_[0] ? $_[0] : \$_[0]) ; - - $] >= 5.008 and (utf8::downgrade($$string, 1) - or croak "Wide character in memGzip"); - - IO::Compress::Gzip::gzip($string, \$out, Minimal => 1) - or return undef ; - - return $out; -} - - -sub _removeGzipHeader($) -{ - my $string = shift ; - - return Z_DATA_ERROR() - if length($$string) < GZIP_MIN_HEADER_SIZE ; - - my ($magic1, $magic2, $method, $flags, $time, $xflags, $oscode) = - unpack ('CCCCVCC', $$string); - - return Z_DATA_ERROR() - unless $magic1 == GZIP_ID1 and $magic2 == GZIP_ID2 and - $method == Z_DEFLATED() and !($flags & GZIP_FLG_RESERVED) ; - substr($$string, 0, GZIP_MIN_HEADER_SIZE) = '' ; - - # skip extra field - if ($flags & GZIP_FLG_FEXTRA) - { - return Z_DATA_ERROR() - if length($$string) < GZIP_FEXTRA_HEADER_SIZE ; - - my ($extra_len) = unpack ('v', $$string); - $extra_len += GZIP_FEXTRA_HEADER_SIZE; - return Z_DATA_ERROR() - if length($$string) < $extra_len ; - - substr($$string, 0, $extra_len) = ''; - } - - # skip orig name - if ($flags & GZIP_FLG_FNAME) - { - my $name_end = index ($$string, GZIP_NULL_BYTE); - return Z_DATA_ERROR() - if $name_end == -1 ; - substr($$string, 0, $name_end + 1) = ''; - } - - # skip comment - if ($flags & GZIP_FLG_FCOMMENT) - { - my $comment_end = index ($$string, GZIP_NULL_BYTE); - return Z_DATA_ERROR() - if $comment_end == -1 ; - substr($$string, 0, $comment_end + 1) = ''; - } - - # skip header crc - if ($flags & GZIP_FLG_FHCRC) - { - return Z_DATA_ERROR() - if length ($$string) < GZIP_FHCRC_SIZE ; - substr($$string, 0, GZIP_FHCRC_SIZE) = ''; - } - - return Z_OK(); -} - - -sub memGunzip($) -{ - # if the buffer isn't a reference, make it one - my $string = (ref $_[0] ? $_[0] : \$_[0]); - - $] >= 5.008 and (utf8::downgrade($$string, 1) - or croak "Wide character in memGunzip"); - - _removeGzipHeader($string) == Z_OK() - or return undef; - - my $bufsize = length $$string > 4096 ? length $$string : 4096 ; - my $x = new Compress::Raw::Zlib::Inflate({-WindowBits => - MAX_WBITS(), - -Bufsize => $bufsize}) - - or return undef; - - my $output = "" ; - my $status = $x->inflate($string, $output); - return undef - unless $status == Z_STREAM_END(); - - if (length $$string >= 8) - { - my ($crc, $len) = unpack ("VV", substr($$string, 0, 8)); - substr($$string, 0, 8) = ''; - return undef - unless $len == length($output) and - $crc == crc32($output); - } - else - { - $$string = ''; - } - return $output; -} - -# Autoload methods go after __END__, and are processed by the autosplit program. - -1; -__END__ - - -=head1 NAME - -Compress::Zlib - Interface to zlib compression library - -=head1 SYNOPSIS - - use Compress::Zlib ; - - ($d, $status) = deflateInit( [OPT] ) ; - $status = $d->deflate($input, $output) ; - $status = $d->flush([$flush_type]) ; - $d->deflateParams(OPTS) ; - $d->deflateTune(OPTS) ; - $d->dict_adler() ; - $d->crc32() ; - $d->adler32() ; - $d->total_in() ; - $d->total_out() ; - $d->msg() ; - $d->get_Strategy(); - $d->get_Level(); - $d->get_BufSize(); - - ($i, $status) = inflateInit( [OPT] ) ; - $status = $i->inflate($input, $output [, $eof]) ; - $status = $i->inflateSync($input) ; - $i->dict_adler() ; - $d->crc32() ; - $d->adler32() ; - $i->total_in() ; - $i->total_out() ; - $i->msg() ; - $d->get_BufSize(); - - $dest = compress($source) ; - $dest = uncompress($source) ; - - $gz = gzopen($filename or filehandle, $mode) ; - $bytesread = $gz->gzread($buffer [,$size]) ; - $bytesread = $gz->gzreadline($line) ; - $byteswritten = $gz->gzwrite($buffer) ; - $status = $gz->gzflush($flush) ; - $offset = $gz->gztell() ; - $status = $gz->gzseek($offset, $whence) ; - $status = $gz->gzclose() ; - $status = $gz->gzeof() ; - $status = $gz->gzsetparams($level, $strategy) ; - $errstring = $gz->gzerror() ; - $gzerrno - - $dest = Compress::Zlib::memGzip($buffer) ; - $dest = Compress::Zlib::memGunzip($buffer) ; - - $crc = adler32($buffer [,$crc]) ; - $crc = crc32($buffer [,$crc]) ; - - $crc = adler32_combine($crc1, $crc2, $len2)l - $crc = crc32_combine($adler1, $adler2, $len2) - - my $version = Compress::Raw::Zlib::zlib_version(); - -=head1 DESCRIPTION - -The I<Compress::Zlib> module provides a Perl interface to the I<zlib> -compression library (see L</AUTHOR> for details about where to get -I<zlib>). - -The C<Compress::Zlib> module can be split into two general areas of -functionality, namely a simple read/write interface to I<gzip> files -and a low-level in-memory compression/decompression interface. - -Each of these areas will be discussed in the following sections. - -=head2 Notes for users of Compress::Zlib version 1 - -The main change in C<Compress::Zlib> version 2.x is that it does not now -interface directly to the zlib library. Instead it uses the -C<IO::Compress::Gzip> and C<IO::Uncompress::Gunzip> modules for -reading/writing gzip files, and the C<Compress::Raw::Zlib> module for some -low-level zlib access. - -The interface provided by version 2 of this module should be 100% backward -compatible with version 1. If you find a difference in the expected -behaviour please contact the author (See L</AUTHOR>). See L<GZIP INTERFACE> - -With the creation of the C<IO::Compress> and C<IO::Uncompress> modules no -new features are planned for C<Compress::Zlib> - the new modules do -everything that C<Compress::Zlib> does and then some. Development on -C<Compress::Zlib> will be limited to bug fixes only. - -If you are writing new code, your first port of call should be one of the -new C<IO::Compress> or C<IO::Uncompress> modules. - -=head1 GZIP INTERFACE - -A number of functions are supplied in I<zlib> for reading and writing -I<gzip> files that conform to RFC 1952. This module provides an interface -to most of them. - -If you have previously used C<Compress::Zlib> 1.x, the following -enhancements/changes have been made to the C<gzopen> interface: - -=over 5 - -=item 1 - -If you want to to open either STDIN or STDOUT with C<gzopen>, you can now -optionally use the special filename "C<->" as a synonym for C<\*STDIN> and -C<\*STDOUT>. - -=item 2 - -In C<Compress::Zlib> version 1.x, C<gzopen> used the zlib library to open -the underlying file. This made things especially tricky when a Perl -filehandle was passed to C<gzopen>. Behind the scenes the numeric C file -descriptor had to be extracted from the Perl filehandle and this passed to -the zlib library. - -Apart from being non-portable to some operating systems, this made it -difficult to use C<gzopen> in situations where you wanted to extract/create -a gzip data stream that is embedded in a larger file, without having to -resort to opening and closing the file multiple times. - -It also made it impossible to pass a perl filehandle that wasn't associated -with a real filesystem file, like, say, an C<IO::String>. - -In C<Compress::Zlib> version 2.x, the C<gzopen> interface has been -completely rewritten to use the L<IO::Compress::Gzip|IO::Compress::Gzip> -for writing gzip files and L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> -for reading gzip files. None of the limitations mentioned above apply. - -=item 3 - -Addition of C<gzseek> to provide a restricted C<seek> interface. - -=item 4. - -Added C<gztell>. - -=back - -A more complete and flexible interface for reading/writing gzip -files/buffers is included with the module C<IO-Compress-Zlib>. See -L<IO::Compress::Gzip|IO::Compress::Gzip> and -L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for more details. - -=over 5 - -=item B<$gz = gzopen($filename, $mode)> - -=item B<$gz = gzopen($filehandle, $mode)> - -This function opens either the I<gzip> file C<$filename> for reading or -writing or attaches to the opened filehandle, C<$filehandle>. -It returns an object on success and C<undef> on failure. - -When writing a gzip file this interface will I<always> create the smallest -possible gzip header (exactly 10 bytes). If you want greater control over -what gets stored in the gzip header (like the original filename or a -comment) use L<IO::Compress::Gzip|IO::Compress::Gzip> instead. Similarly if -you want to read the contents of the gzip header use -L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>. - -The second parameter, C<$mode>, is used to specify whether the file is -opened for reading or writing and to optionally specify a compression -level and compression strategy when writing. The format of the C<$mode> -parameter is similar to the mode parameter to the 'C' function C<fopen>, -so "rb" is used to open for reading, "wb" for writing and "ab" for -appending (writing at the end of the file). - -To specify a compression level when writing, append a digit between 0 -and 9 to the mode string -- 0 means no compression and 9 means maximum -compression. -If no compression level is specified Z_DEFAULT_COMPRESSION is used. - -To specify the compression strategy when writing, append 'f' for filtered -data, 'h' for Huffman only compression, or 'R' for run-length encoding. -If no strategy is specified Z_DEFAULT_STRATEGY is used. - -So, for example, "wb9" means open for writing with the maximum compression -using the default strategy and "wb4R" means open for writing with compression -level 4 and run-length encoding. - -Refer to the I<zlib> documentation for the exact format of the C<$mode> -parameter. - -=item B<$bytesread = $gz-E<gt>gzread($buffer [, $size]) ;> - -Reads C<$size> bytes from the compressed file into C<$buffer>. If -C<$size> is not specified, it will default to 4096. If the scalar -C<$buffer> is not large enough, it will be extended automatically. - -Returns the number of bytes actually read. On EOF it returns 0 and in -the case of an error, -1. - -=item B<$bytesread = $gz-E<gt>gzreadline($line) ;> - -Reads the next line from the compressed file into C<$line>. - -Returns the number of bytes actually read. On EOF it returns 0 and in -the case of an error, -1. - -It is legal to intermix calls to C<gzread> and C<gzreadline>. - -To maintain backward compatibility with version 1.x of this module -C<gzreadline> ignores the C<$/> variable - it I<always> uses the string -C<"\n"> as the line delimiter. - -If you want to read a gzip file a line at a time and have it respect the -C<$/> variable (or C<$INPUT_RECORD_SEPARATOR>, or C<$RS> when C<English> is -in use) see L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>. - -=item B<$byteswritten = $gz-E<gt>gzwrite($buffer) ;> - -Writes the contents of C<$buffer> to the compressed file. Returns the -number of bytes actually written, or 0 on error. - -=item B<$status = $gz-E<gt>gzflush($flush_type) ;> - -Flushes all pending output into the compressed file. - -This method takes an optional parameter, C<$flush_type>, that controls -how the flushing will be carried out. By default the C<$flush_type> -used is C<Z_FINISH>. Other valid values for C<$flush_type> are -C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is -strongly recommended that you only set the C<flush_type> parameter if -you fully understand the implications of what it does - overuse of C<flush> -can seriously degrade the level of compression achieved. See the C<zlib> -documentation for details. - -Returns 0 on success. - -=item B<$offset = $gz-E<gt>gztell() ;> - -Returns the uncompressed file offset. - -=item B<$status = $gz-E<gt>gzseek($offset, $whence) ;> - -Provides a sub-set of the C<seek> functionality, with the restriction -that it is only legal to seek forward in the compressed file. -It is a fatal error to attempt to seek backward. - -When opened for writing, empty parts of the file will have NULL (0x00) -bytes written to them. - -The C<$whence> parameter should be one of SEEK_SET, SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=item B<$gz-E<gt>gzclose> - -Closes the compressed file. Any pending data is flushed to the file -before it is closed. - -Returns 0 on success. - -=item B<$gz-E<gt>gzsetparams($level, $strategy> - -Change settings for the deflate stream C<$gz>. - -The list of the valid options is shown below. Options not specified -will remain unchanged. - -Note: This method is only available if you are running zlib 1.0.6 or better. - -=over 5 - -=item B<$level> - -Defines the compression level. Valid values are 0 through 9, -C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and -C<Z_DEFAULT_COMPRESSION>. - -=item B<$strategy> - -Defines the strategy used to tune the compression. The valid values are -C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>. - -=back - -=item B<$gz-E<gt>gzerror> - -Returns the I<zlib> error message or number for the last operation -associated with C<$gz>. The return value will be the I<zlib> error -number when used in a numeric context and the I<zlib> error message -when used in a string context. The I<zlib> error number constants, -shown below, are available for use. - - Z_OK - Z_STREAM_END - Z_ERRNO - Z_STREAM_ERROR - Z_DATA_ERROR - Z_MEM_ERROR - Z_BUF_ERROR - -=item B<$gzerrno> - -The C<$gzerrno> scalar holds the error code associated with the most -recent I<gzip> routine. Note that unlike C<gzerror()>, the error is -I<not> associated with a particular file. - -As with C<gzerror()> it returns an error number in numeric context and -an error message in string context. Unlike C<gzerror()> though, the -error message will correspond to the I<zlib> message when the error is -associated with I<zlib> itself, or the UNIX error message when it is -not (i.e. I<zlib> returned C<Z_ERRORNO>). - -As there is an overlap between the error numbers used by I<zlib> and -UNIX, C<$gzerrno> should only be used to check for the presence of -I<an> error in numeric context. Use C<gzerror()> to check for specific -I<zlib> errors. The I<gzcat> example below shows how the variable can -be used safely. - -=back - -=head2 Examples - -Here is an example script which uses the interface. It implements a -I<gzcat> function. - - use strict ; - use warnings ; - - use Compress::Zlib ; - - # use stdin if no files supplied - @ARGV = '-' unless @ARGV ; - - foreach my $file (@ARGV) { - my $buffer ; - - my $gz = gzopen($file, "rb") - or die "Cannot open $file: $gzerrno\n" ; - - print $buffer while $gz->gzread($buffer) > 0 ; - - die "Error reading from $file: $gzerrno" . ($gzerrno+0) . "\n" - if $gzerrno != Z_STREAM_END ; - - $gz->gzclose() ; - } - -Below is a script which makes use of C<gzreadline>. It implements a -very simple I<grep> like script. - - use strict ; - use warnings ; - - use Compress::Zlib ; - - die "Usage: gzgrep pattern [file...]\n" - unless @ARGV >= 1; - - my $pattern = shift ; - - # use stdin if no files supplied - @ARGV = '-' unless @ARGV ; - - foreach my $file (@ARGV) { - my $gz = gzopen($file, "rb") - or die "Cannot open $file: $gzerrno\n" ; - - while ($gz->gzreadline($_) > 0) { - print if /$pattern/ ; - } - - die "Error reading from $file: $gzerrno\n" - if $gzerrno != Z_STREAM_END ; - - $gz->gzclose() ; - } - -This script, I<gzstream>, does the opposite of the I<gzcat> script -above. It reads from standard input and writes a gzip data stream to -standard output. - - use strict ; - use warnings ; - - use Compress::Zlib ; - - binmode STDOUT; # gzopen only sets it on the fd - - my $gz = gzopen(\*STDOUT, "wb") - or die "Cannot open stdout: $gzerrno\n" ; - - while (<>) { - $gz->gzwrite($_) - or die "error writing: $gzerrno\n" ; - } - - $gz->gzclose ; - -=head2 Compress::Zlib::memGzip - -This function is used to create an in-memory gzip file with the minimum -possible gzip header (exactly 10 bytes). - - $dest = Compress::Zlib::memGzip($buffer) ; - -If successful, it returns the in-memory gzip file, otherwise it returns -undef. - -The C<$buffer> parameter can either be a scalar or a scalar reference. - -See L<IO::Compress::Gzip|IO::Compress::Gzip> for an alternative way to -carry out in-memory gzip compression. - -=head2 Compress::Zlib::memGunzip - -This function is used to uncompress an in-memory gzip file. - - $dest = Compress::Zlib::memGunzip($buffer) ; - -If successful, it returns the uncompressed gzip file, otherwise it -returns undef. - -The C<$buffer> parameter can either be a scalar or a scalar reference. The -contents of the C<$buffer> parameter are destroyed after calling this function. - -If C<$buffer> consists of multiple concatenated gzip data streams only the -first will be uncompressed. Use C<gunzip> with the C<MultiStream> option in -the C<IO::Uncompress::Gunzip> module if you need to deal with concatenated -data streams. - -See L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for an alternative way -to carry out in-memory gzip uncompression. - -=head1 COMPRESS/UNCOMPRESS - -Two functions are provided to perform in-memory compression/uncompression of -RFC 1950 data streams. They are called C<compress> and C<uncompress>. - -=over 5 - -=item B<$dest = compress($source [, $level] ) ;> - -Compresses C<$source>. If successful it returns the compressed -data. Otherwise it returns I<undef>. - -The source buffer, C<$source>, can either be a scalar or a scalar -reference. - -The C<$level> parameter defines the compression level. Valid values are -0 through 9, C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, -C<Z_BEST_COMPRESSION>, and C<Z_DEFAULT_COMPRESSION>. -If C<$level> is not specified C<Z_DEFAULT_COMPRESSION> will be used. - -=item B<$dest = uncompress($source) ;> - -Uncompresses C<$source>. If successful it returns the uncompressed -data. Otherwise it returns I<undef>. - -The source buffer can either be a scalar or a scalar reference. - -=back - -Please note: the two functions defined above are I<not> compatible with -the Unix commands of the same name. - -See L<IO::Deflate|IO::Deflate> and L<IO::Inflate|IO::Inflate> included with -this distribution for an alternative interface for reading/writing RFC 1950 -files/buffers. - -=head1 Deflate Interface - -This section defines an interface that allows in-memory compression using -the I<deflate> interface provided by zlib. - -Here is a definition of the interface available: - -=head2 B<($d, $status) = deflateInit( [OPT] )> - -Initialises a deflation stream. - -It combines the features of the I<zlib> functions C<deflateInit>, -C<deflateInit2> and C<deflateSetDictionary>. - -If successful, it will return the initialised deflation stream, C<$d> -and C<$status> of C<Z_OK> in a list context. In scalar context it -returns the deflation stream, C<$d>, only. - -If not successful, the returned deflation stream (C<$d>) will be -I<undef> and C<$status> will hold the exact I<zlib> error code. - -The function optionally takes a number of named options specified as -C<< -Name=>value >> pairs. This allows individual options to be -tailored without having to specify them all in the parameter list. - -For backward compatibility, it is also possible to pass the parameters -as a reference to a hash containing the name=>value pairs. - -The function takes one optional parameter, a reference to a hash. The -contents of the hash allow the deflation interface to be tailored. - -Here is a list of the valid options: - -=over 5 - -=item B<-Level> - -Defines the compression level. Valid values are 0 through 9, -C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and -C<Z_DEFAULT_COMPRESSION>. - -The default is Z_DEFAULT_COMPRESSION. - -=item B<-Method> - -Defines the compression method. The only valid value at present (and -the default) is Z_DEFLATED. - -=item B<-WindowBits> - -To create an RFC 1950 data stream, set C<WindowBits> to a positive number. - -To create an RFC 1951 data stream, set C<WindowBits> to C<-MAX_WBITS>. - -For a full definition of the meaning and valid values for C<WindowBits> refer -to the I<zlib> documentation for I<deflateInit2>. - -Defaults to MAX_WBITS. - -=item B<-MemLevel> - -For a definition of the meaning and valid values for C<MemLevel> -refer to the I<zlib> documentation for I<deflateInit2>. - -Defaults to MAX_MEM_LEVEL. - -=item B<-Strategy> - -Defines the strategy used to tune the compression. The valid values are -C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>. - -The default is Z_DEFAULT_STRATEGY. - -=item B<-Dictionary> - -When a dictionary is specified I<Compress::Zlib> will automatically -call C<deflateSetDictionary> directly after calling C<deflateInit>. The -Adler32 value for the dictionary can be obtained by calling the method -C<$d->dict_adler()>. - -The default is no dictionary. - -=item B<-Bufsize> - -Sets the initial size for the deflation buffer. If the buffer has to be -reallocated to increase the size, it will grow in increments of -C<Bufsize>. - -The default is 4096. - -=back - -Here is an example of using the C<deflateInit> optional parameter list -to override the default buffer size and compression level. All other -options will take their default values. - - deflateInit( -Bufsize => 300, - -Level => Z_BEST_SPEED ) ; - -=head2 B<($out, $status) = $d-E<gt>deflate($buffer)> - -Deflates the contents of C<$buffer>. The buffer can either be a scalar -or a scalar reference. When finished, C<$buffer> will be -completely processed (assuming there were no errors). If the deflation -was successful it returns the deflated output, C<$out>, and a status -value, C<$status>, of C<Z_OK>. - -On error, C<$out> will be I<undef> and C<$status> will contain the -I<zlib> error code. - -In a scalar context C<deflate> will return C<$out> only. - -As with the I<deflate> function in I<zlib>, it is not necessarily the -case that any output will be produced by this method. So don't rely on -the fact that C<$out> is empty for an error test. - -=head2 B<($out, $status) = $d-E<gt>flush()> -=head2 B<($out, $status) = $d-E<gt>flush($flush_type)> - -Typically used to finish the deflation. Any pending output will be -returned via C<$out>. -C<$status> will have a value C<Z_OK> if successful. - -In a scalar context C<flush> will return C<$out> only. - -Note that flushing can seriously degrade the compression ratio, so it -should only be used to terminate a decompression (using C<Z_FINISH>) or -when you want to create a I<full flush point> (using C<Z_FULL_FLUSH>). - -By default the C<flush_type> used is C<Z_FINISH>. Other valid values -for C<flush_type> are C<Z_NO_FLUSH>, C<Z_PARTIAL_FLUSH>, C<Z_SYNC_FLUSH> -and C<Z_FULL_FLUSH>. It is strongly recommended that you only set the -C<flush_type> parameter if you fully understand the implications of -what it does. See the C<zlib> documentation for details. - -=head2 B<$status = $d-E<gt>deflateParams([OPT])> - -Change settings for the deflate stream C<$d>. - -The list of the valid options is shown below. Options not specified -will remain unchanged. - -=over 5 - -=item B<-Level> - -Defines the compression level. Valid values are 0 through 9, -C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and -C<Z_DEFAULT_COMPRESSION>. - -=item B<-Strategy> - -Defines the strategy used to tune the compression. The valid values are -C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>. - -=back - -=head2 B<$d-E<gt>dict_adler()> - -Returns the adler32 value for the dictionary. - -=head2 B<$d-E<gt>msg()> - -Returns the last error message generated by zlib. - -=head2 B<$d-E<gt>total_in()> - -Returns the total number of bytes uncompressed bytes input to deflate. - -=head2 B<$d-E<gt>total_out()> - -Returns the total number of compressed bytes output from deflate. - -=head2 Example - -Here is a trivial example of using C<deflate>. It simply reads standard -input, deflates it and writes it to standard output. - - use strict ; - use warnings ; - - use Compress::Zlib ; - - binmode STDIN; - binmode STDOUT; - my $x = deflateInit() - or die "Cannot create a deflation stream\n" ; - - my ($output, $status) ; - while (<>) - { - ($output, $status) = $x->deflate($_) ; - - $status == Z_OK - or die "deflation failed\n" ; - - print $output ; - } - - ($output, $status) = $x->flush() ; - - $status == Z_OK - or die "deflation failed\n" ; - - print $output ; - -=head1 Inflate Interface - -This section defines the interface available that allows in-memory -uncompression using the I<deflate> interface provided by zlib. - -Here is a definition of the interface: - -=head2 B<($i, $status) = inflateInit()> - -Initialises an inflation stream. - -In a list context it returns the inflation stream, C<$i>, and the -I<zlib> status code in C<$status>. In a scalar context it returns the -inflation stream only. - -If successful, C<$i> will hold the inflation stream and C<$status> will -be C<Z_OK>. - -If not successful, C<$i> will be I<undef> and C<$status> will hold the -I<zlib> error code. - -The function optionally takes a number of named options specified as -C<< -Name=>value >> pairs. This allows individual options to be -tailored without having to specify them all in the parameter list. - -For backward compatibility, it is also possible to pass the parameters -as a reference to a hash containing the name=>value pairs. - -The function takes one optional parameter, a reference to a hash. The -contents of the hash allow the deflation interface to be tailored. - -Here is a list of the valid options: - -=over 5 - -=item B<-WindowBits> - -To uncompress an RFC 1950 data stream, set C<WindowBits> to a positive number. - -To uncompress an RFC 1951 data stream, set C<WindowBits> to C<-MAX_WBITS>. - -For a full definition of the meaning and valid values for C<WindowBits> refer -to the I<zlib> documentation for I<inflateInit2>. - -Defaults to MAX_WBITS. - -=item B<-Bufsize> - -Sets the initial size for the inflation buffer. If the buffer has to be -reallocated to increase the size, it will grow in increments of -C<Bufsize>. - -Default is 4096. - -=item B<-Dictionary> - -The default is no dictionary. - -=back - -Here is an example of using the C<inflateInit> optional parameter to -override the default buffer size. - - inflateInit( -Bufsize => 300 ) ; - -=head2 B<($out, $status) = $i-E<gt>inflate($buffer)> - -Inflates the complete contents of C<$buffer>. The buffer can either be -a scalar or a scalar reference. - -Returns C<Z_OK> if successful and C<Z_STREAM_END> if the end of the -compressed data has been successfully reached. -If not successful, C<$out> will be I<undef> and C<$status> will hold -the I<zlib> error code. - -The C<$buffer> parameter is modified by C<inflate>. On completion it -will contain what remains of the input buffer after inflation. This -means that C<$buffer> will be an empty string when the return status is -C<Z_OK>. When the return status is C<Z_STREAM_END> the C<$buffer> -parameter will contains what (if anything) was stored in the input -buffer after the deflated data stream. - -This feature is useful when processing a file format that encapsulates -a compressed data stream (e.g. gzip, zip). - -=head2 B<$status = $i-E<gt>inflateSync($buffer)> - -Scans C<$buffer> until it reaches either a I<full flush point> or the -end of the buffer. - -If a I<full flush point> is found, C<Z_OK> is returned and C<$buffer> -will be have all data up to the flush point removed. This can then be -passed to the C<deflate> method. - -Any other return code means that a flush point was not found. If more -data is available, C<inflateSync> can be called repeatedly with more -compressed data until the flush point is found. - -=head2 B<$i-E<gt>dict_adler()> - -Returns the adler32 value for the dictionary. - -=head2 B<$i-E<gt>msg()> - -Returns the last error message generated by zlib. - -=head2 B<$i-E<gt>total_in()> - -Returns the total number of bytes compressed bytes input to inflate. - -=head2 B<$i-E<gt>total_out()> - -Returns the total number of uncompressed bytes output from inflate. - -=head2 Example - -Here is an example of using C<inflate>. - - use strict ; - use warnings ; - - use Compress::Zlib ; - - my $x = inflateInit() - or die "Cannot create a inflation stream\n" ; - - my $input = '' ; - binmode STDIN; - binmode STDOUT; - - my ($output, $status) ; - while (read(STDIN, $input, 4096)) - { - ($output, $status) = $x->inflate(\$input) ; - - print $output - if $status == Z_OK or $status == Z_STREAM_END ; - - last if $status != Z_OK ; - } - - die "inflation failed\n" - unless $status == Z_STREAM_END ; - -=head1 CHECKSUM FUNCTIONS - -Two functions are provided by I<zlib> to calculate checksums. For the -Perl interface, the order of the two parameters in both functions has -been reversed. This allows both running checksums and one off -calculations to be done. - - $crc = adler32($buffer [,$crc]) ; - $crc = crc32($buffer [,$crc]) ; - -The buffer parameters can either be a scalar or a scalar reference. - -If the $crc parameters is C<undef>, the crc value will be reset. - -If you have built this module with zlib 1.2.3 or better, two more -CRC-related functions are available. - - $crc = adler32_combine($crc1, $crc2, $len2)l - $crc = crc32_combine($adler1, $adler2, $len2) - -These functions allow checksums to be merged. - -=head1 Misc - -=head2 my $version = Compress::Zlib::zlib_version(); - -Returns the version of the zlib library. - -=head1 CONSTANTS - -All the I<zlib> constants are automatically imported when you make use -of I<Compress::Zlib>. - -=head1 SEE ALSO - -L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 1995-2009 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/IO-Compress/lib/File/GlobMapper.pm b/ext/IO-Compress/lib/File/GlobMapper.pm deleted file mode 100644 index 40a606309e..0000000000 --- a/ext/IO-Compress/lib/File/GlobMapper.pm +++ /dev/null @@ -1,679 +0,0 @@ -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 = '1.000'; -@EXPORT_OK = qw( globmap ); - - -our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount); -$noPreBS = '(?<!\\\)' ; # no preceeding backslash -$metachars = '.*?[](){}'; -$matchMetaRE = '[' . quotemeta($metachars) . ']'; - -%mapping = ( - '*' => '([^/]*)', - '?' => '([^/])', - '.' => '\.', - '[' => '([', - '(' => '(', - ')' => ')', - ); - -%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /; - -sub globmap ($$;) -{ - my $inputGlob = shift ; - my $outputGlob = shift ; - - my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_) - or croak "globmap: $Error" ; - return $obj->getFileMap(); -} - -sub new -{ - my $class = shift ; - my $inputGlob = shift ; - my $outputGlob = shift ; - # TODO -- flags needs to default to whatever File::Glob does - my $flags = shift || $CSH_GLOB ; - #my $flags = shift ; - - $inputGlob =~ s/^\s*\<\s*//; - $inputGlob =~ s/\s*\>\s*$//; - - $outputGlob =~ s/^\s*\<\s*//; - $outputGlob =~ s/\s*\>\s*$//; - - my %object = - ( InputGlob => $inputGlob, - OutputGlob => $outputGlob, - GlobFlags => $flags, - Braces => 0, - WildCount => 0, - Pairs => [], - Sigil => '#', - ); - - my $self = bless \%object, ref($class) || $class ; - - $self->_parseInputGlob() - or return undef ; - - $self->_parseOutputGlob() - or return undef ; - - my @inputFiles = globber($self->{InputGlob}, $flags) ; - - if (GLOB_ERROR) - { - $Error = $!; - return undef ; - } - - #if (whatever) - { - my $missing = grep { ! -e $_ } @inputFiles ; - - if ($missing) - { - $Error = "$missing input files do not exist"; - return undef ; - } - } - - $self->{InputFiles} = \@inputFiles ; - - $self->_getFiles() - or return undef ; - - return $self; -} - -sub _retError -{ - my $string = shift ; - $Error = "$string in input fileglob" ; - return undef ; -} - -sub _unmatched -{ - my $delimeter = shift ; - - _retError("Unmatched $delimeter"); - return undef ; -} - -sub _parseBit -{ - my $self = shift ; - - my $string = shift ; - - my $out = ''; - my $depth = 0 ; - - while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//) - { - $out .= quotemeta($1) ; - $out .= $mapping{$2} if defined $mapping{$2}; - - ++ $self->{WildCount} if $wildCount{$2} ; - - if ($2 eq ',') - { - return _unmatched "(" - if $depth ; - - $out .= '|'; - } - elsif ($2 eq '(') - { - ++ $depth ; - } - elsif ($2 eq ')') - { - return _unmatched ")" - if ! $depth ; - - -- $depth ; - } - elsif ($2 eq '[') - { - # TODO -- quotemeta & check no '/' - # TODO -- check for \] & other \ within the [] - $string =~ s#(.*?\])## - or return _unmatched "[" ; - $out .= "$1)" ; - } - elsif ($2 eq ']') - { - return _unmatched "]" ; - } - elsif ($2 eq '{' || $2 eq '}') - { - return _retError "Nested {} not allowed" ; - } - } - - $out .= quotemeta $string; - - return _unmatched "(" - if $depth ; - - return $out ; -} - -sub _parseInputGlob -{ - my $self = shift ; - - my $string = $self->{InputGlob} ; - my $inGlob = ''; - - # Multiple concatenated *'s don't make sense - #$string =~ s#\*\*+#*# ; - - # TODO -- Allow space to delimit patterns? - #my @strings = split /\s+/, $string ; - #for my $str (@strings) - my $out = ''; - my $depth = 0 ; - - while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//) - { - $out .= quotemeta($1) ; - $out .= $mapping{$2} if defined $mapping{$2}; - ++ $self->{WildCount} if $wildCount{$2} ; - - if ($2 eq '(') - { - ++ $depth ; - } - elsif ($2 eq ')') - { - return _unmatched ")" - if ! $depth ; - - -- $depth ; - } - elsif ($2 eq '[') - { - # TODO -- quotemeta & check no '/' or '(' or ')' - # TODO -- check for \] & other \ within the [] - $string =~ s#(.*?\])## - or return _unmatched "["; - $out .= "$1)" ; - } - elsif ($2 eq ']') - { - return _unmatched "]" ; - } - elsif ($2 eq '}') - { - return _unmatched "}" ; - } - elsif ($2 eq '{') - { - # TODO -- check no '/' within the {} - # TODO -- check for \} & other \ within the {} - - my $tmp ; - unless ( $string =~ s/(.*?)$noPreBS\}//) - { - return _unmatched "{"; - } - #$string =~ s#(.*?)\}##; - - #my $alt = join '|', - # map { quotemeta $_ } - # split "$noPreBS,", $1 ; - my $alt = $self->_parseBit($1); - defined $alt or return 0 ; - $out .= "($alt)" ; - - ++ $self->{Braces} ; - } - } - - return _unmatched "(" - if $depth ; - - $out .= quotemeta $string ; - - - $self->{InputGlob} =~ s/$noPreBS[\(\)]//g; - $self->{InputPattern} = $out ; - - #print "# INPUT '$self->{InputGlob}' => '$out'\n"; - - return 1 ; - -} - -sub _parseOutputGlob -{ - my $self = shift ; - - my $string = $self->{OutputGlob} ; - my $maxwild = $self->{WildCount}; - - if ($self->{GlobFlags} & GLOB_TILDE) - #if (1) - { - $string =~ s{ - ^ ~ # find a leading tilde - ( # save this in $1 - [^/] # a non-slash character - * # repeated 0 or more times (0 means me) - ) - }{ - $1 - ? (getpwnam($1))[7] - : ( $ENV{HOME} || $ENV{LOGDIR} ) - }ex; - - } - - # max #1 must be == to max no of '*' in input - while ( $string =~ m/#(\d)/g ) - { - croak "Max wild is #$maxwild, you tried #$1" - if $1 > $maxwild ; - } - - my $noPreBS = '(?<!\\\)' ; # no preceeding backslash - #warn "noPreBS = '$noPreBS'\n"; - - #$string =~ s/${noPreBS}\$(\d)/\${$1}/g; - $string =~ s/${noPreBS}#(\d)/\${$1}/g; - $string =~ s#${noPreBS}\*#\${inFile}#g; - $string = '"' . $string . '"'; - - #print "OUTPUT '$self->{OutputGlob}' => '$string'\n"; - $self->{OutputPattern} = $string ; - - return 1 ; -} - -sub _getFiles -{ - my $self = shift ; - - my %outInMapping = (); - my %inFiles = () ; - - foreach my $inFile (@{ $self->{InputFiles} }) - { - next if $inFiles{$inFile} ++ ; - - my $outFile = $inFile ; - - if ( $inFile =~ m/$self->{InputPattern}/ ) - { - no warnings 'uninitialized'; - eval "\$outFile = $self->{OutputPattern};" ; - - if (defined $outInMapping{$outFile}) - { - $Error = "multiple input files map to one output file"; - return undef ; - } - $outInMapping{$outFile} = $inFile; - push @{ $self->{Pairs} }, [$inFile, $outFile]; - } - } - - return 1 ; -} - -sub getFileMap -{ - my $self = shift ; - - return $self->{Pairs} ; -} - -sub getHash -{ - my $self = shift ; - - return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ; -} - -1; - -__END__ - -=head1 NAME - -File::GlobMapper - Extend File Glob to Allow Input and Output Files - -=head1 SYNOPSIS - - use File::GlobMapper qw( globmap ); - - my $aref = globmap $input => $output - or die $File::GlobMapper::Error ; - - my $gm = new File::GlobMapper $input => $output - or die $File::GlobMapper::Error ; - - -=head1 DESCRIPTION - -This module needs Perl5.005 or better. - -This module takes the existing C<File::Glob> module as a starting point and -extends it to allow new filenames to be derived from the files matched by -C<File::Glob>. - -This can be useful when carrying out batch operations on multiple files that -have both an input filename and output filename and the output file can be -derived from the input filename. Examples of operations where this can be -useful include, file renaming, file copying and file compression. - - -=head2 Behind The Scenes - -To help explain what C<File::GlobMapper> does, consider what code you -would write if you wanted to rename all files in the current directory -that ended in C<.tar.gz> to C<.tgz>. So say these files are in the -current 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<exactly> what C<File::GlobMapper> does. - -Here is same snippet of code rewritten using C<globmap> - - for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' ) - { - my ($from, $to) = @$pair; - rename $from => $to - or die "Cannot rename '$old' to '$new': $!\n; - } - -So how does it work? - -Behind the scenes the C<globmap> function does a combination of a -file glob to match existing filenames followed by a substitute -to create the new filenames. - -Notice how both parameters to C<globmap> are strings that are 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<globmap>, C<*.tar.gz>, is an I<Input File Glob>. -Once the enclosing "< ... >" is removed, this is passed (more or -less) unchanged to C<File::Glob> to carry out a file match. - -Next the fileglob C<*.tar.gz> is transformed behind the scenes into a -full Perl regular expression, with the additional step of wrapping each -transformed wildcard metacharacter sequence in parenthesis. - -In this case the input fileglob C<*.tar.gz> will be transformed into -this Perl regular expression - - ([^/]*)\.tar\.gz - -Wrapping with parenthesis allows the wildcard parts of the Input File -Glob to be referenced by the second parameter to C<globmap>, C<#1.tgz>, -the I<Output File Glob>. This parameter operates just like the replacement -part of a substitute command. The difference is that the C<#1> syntax -is used to reference sub-patterns matched in the input fileglob, rather -than the C<$1> syntax that is used with perl regular expressions. In -this case C<#1> is used to refer to the text matched by the C<*> in the -Input File Glob. This makes it easier to use this module where the -parameters to C<globmap> are typed at the command line. - -The final step involves passing each filename matched by the C<*.tar.gz> -file glob through the derived Perl regular expression in turn and -expanding the output fileglob using it. - -The end result of all this is a list of pairs of filenames. By default -that is what is returned by C<globmap>. In this example the data structure -returned will look like this - - ( ['alpha.tar.gz' => 'alpha.tgz'], - ['beta.tar.gz' => 'beta.tgz' ], - ['gamma.tar.gz' => 'gamma.tgz'] - ) - - -Each pair is an array reference with two elements - namely the I<from> -filename, that C<File::Glob> has matched, and a I<to> filename that is -derived from the I<from> filename. - - - -=head2 Limitations - -C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to -solve all filename mapping operations. Under the hood C<File::Glob> (or for -older versions of Perl, C<File::BSDGlob>) is used to match the files, so you -will never have the flexibility of full Perl regular expression. - -=head2 Input File Glob - -The syntax for an Input FileGlob is identical to C<File::Glob>, except -for the following - -=over 5 - -=item 1. - -No nested {} - -=item 2. - -Whitespace does not delimit fileglobs. - -=item 3. - -The use of parenthesis can be used to capture parts of the input filename. - -=item 4. - -If an Input glob matches the same file more than once, only the first -will be used. - -=back - -The syntax - -=over 5 - -=item B<~> - -=item B<~user> - - -=item B<.> - -Matches a literal '.'. -Equivalent to the Perl regular expression - - \. - -=item B<*> - -Matches zero or more characters, except '/'. Equivalent to the Perl -regular expression - - [^/]* - -=item B<?> - -Matches zero or one character, except '/'. Equivalent to the Perl -regular expression - - [^/]? - -=item B<\> - -Backslash is used, as usual, to escape the next character. - -=item B<[]> - -Character class. - -=item B<{,}> - -Alternation - -=item B<()> - -Capturing parenthesis that work just like perl - -=back - -Any other character it taken literally. - -=head2 Output File Glob - -The Output File Glob is a normal string, with 2 glob-like features. - -The first is the '*' metacharacter. This will be replaced by the complete -filename matched by the input file glob. So - - *.c *.Z - -The second is - -Output FileGlobs take the - -=over 5 - -=item "*" - -The "*" 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<globmap> to determine the -source and destination filenames. - - use File::GlobMapper qw(globmap) ; - use File::Copy; - - die "rename: Usage rename 'from' 'to'\n" - unless @ARGV == 2 ; - - my $fromGlob = shift @ARGV; - my $toGlob = shift @ARGV; - - my $pairs = globmap($fromGlob, $toGlob) - or die $File::GlobMapper::Error; - - for my $pair (@$pairs) - { - my ($from, $to) = @$pair; - move $from => $to ; - } - - - -Here is an example that renames all c files to cpp. - - $ rename '*.c' '#1.cpp' - -=head2 A few example globmaps - -Below are a few examples of globmaps - -To copy all your .c file to a backup directory - - '</my/home/*.c>' '</my/backup/#1.c>' - -If you want to compress all - - '</my/home/*.[ch]>' '<*.gz>' - -To uncompress - - '</my/home/*.[ch].gz>' '</my/home/#1.#2>' - -=head1 SEE ALSO - -L<File::Glob|File::Glob> - -=head1 AUTHOR - -The I<File::GlobMapper> module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005 Paul Marquess. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. diff --git a/ext/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm b/ext/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm deleted file mode 100644 index a56331d2cb..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm +++ /dev/null @@ -1,162 +0,0 @@ -package IO::Compress::Adapter::Bzip2 ; - -use strict; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(:Status); - -#use Compress::Bzip2 ; -use Compress::Raw::Bzip2 2.021 ; - -our ($VERSION); -$VERSION = '2.021'; - -sub mkCompObject -{ - my $BlockSize100K = shift ; - my $WorkFactor = shift ; - my $Verbosity = shift ; - - my ($def, $status) = new Compress::Raw::Bzip2(1, $BlockSize100K, - $WorkFactor, $Verbosity); - #my ($def, $status) = bzdeflateInit(); - #-BlockSize100K => $params->value('BlockSize100K'), - #-WorkFactor => $params->value('WorkFactor'); - - return (undef, "Could not create Deflate object: $status", $status) - if $status != BZ_OK ; - - return bless {'Def' => $def, - 'Error' => '', - 'ErrorNo' => 0, - } ; -} - -sub compr -{ - my $self = shift ; - - my $def = $self->{Def}; - - #my ($out, $status) = $def->bzdeflate(defined ${$_[0]} ? ${$_[0]} : "") ; - my $status = $def->bzdeflate($_[0], $_[1]) ; - $self->{ErrorNo} = $status; - - if ($status != BZ_RUN_OK) - { - $self->{Error} = "Deflate Error: $status"; - return STATUS_ERROR; - } - - #${ $_[1] } .= $out if defined $out; - - return STATUS_OK; -} - -sub flush -{ - my $self = shift ; - - my $def = $self->{Def}; - - #my ($out, $status) = $def->bzflush($opt); - #my $status = $def->bzflush($_[0], $opt); - my $status = $def->bzflush($_[0]); - $self->{ErrorNo} = $status; - - if ($status != BZ_RUN_OK) - { - $self->{Error} = "Deflate Error: $status"; - return STATUS_ERROR; - } - - #${ $_[0] } .= $out if defined $out ; - return STATUS_OK; - -} - -sub close -{ - my $self = shift ; - - my $def = $self->{Def}; - - #my ($out, $status) = $def->bzclose(); - my $status = $def->bzclose($_[0]); - $self->{ErrorNo} = $status; - - if ($status != BZ_STREAM_END) - { - $self->{Error} = "Deflate Error: $status"; - return STATUS_ERROR; - } - - #${ $_[0] } .= $out if defined $out ; - return STATUS_OK; - -} - - -sub reset -{ - my $self = shift ; - - my $outer = $self->{Outer}; - - my ($def, $status) = new Compress::Raw::Bzip2(); - $self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ; - - if ($status != BZ_OK) - { - $self->{Error} = "Cannot create Deflate object: $status"; - return STATUS_ERROR; - } - - $self->{Def} = $def; - - return STATUS_OK; -} - -sub compressedBytes -{ - my $self = shift ; - $self->{Def}->compressedBytes(); -} - -sub uncompressedBytes -{ - my $self = shift ; - $self->{Def}->uncompressedBytes(); -} - -#sub total_out -#{ -# my $self = shift ; -# 0; -#} -# - -#sub total_in -#{ -# my $self = shift ; -# $self->{Def}->total_in(); -#} -# -#sub crc32 -#{ -# my $self = shift ; -# $self->{Def}->crc32(); -#} -# -#sub adler32 -#{ -# my $self = shift ; -# $self->{Def}->adler32(); -#} - - -1; - -__END__ - diff --git a/ext/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm b/ext/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm deleted file mode 100644 index 525868093c..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm +++ /dev/null @@ -1,165 +0,0 @@ -package IO::Compress::Adapter::Deflate ; - -use strict; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(:Status); - -use Compress::Raw::Zlib 2.021 qw(Z_OK Z_FINISH MAX_WBITS) ; -our ($VERSION); - -$VERSION = '2.021'; - -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/IO-Compress/lib/IO/Compress/Adapter/Identity.pm b/ext/IO-Compress/lib/IO/Compress/Adapter/Identity.pm deleted file mode 100644 index c980e6c343..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Adapter/Identity.pm +++ /dev/null @@ -1,101 +0,0 @@ -package IO::Compress::Adapter::Identity ; - -use strict; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(:Status); -our ($VERSION); - -$VERSION = '2.021'; - -sub mkCompObject -{ - my $level = shift ; - my $strategy = shift ; - - return bless { - 'CompSize' => 0, - 'UnCompSize' => 0, - 'Error' => '', - 'ErrorNo' => 0, - } ; -} - -sub compr -{ - my $self = shift ; - - if (defined ${ $_[0] } && length ${ $_[0] }) { - $self->{CompSize} += length ${ $_[0] } ; - $self->{UnCompSize} = $self->{CompSize} ; - - if ( ref $_[1] ) - { ${ $_[1] } .= ${ $_[0] } } - else - { $_[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; - - 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} ; -} - -1; - - -__END__ - diff --git a/ext/IO-Compress/lib/IO/Compress/Base.pm b/ext/IO-Compress/lib/IO/Compress/Base.pm deleted file mode 100644 index 7b558eafeb..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Base.pm +++ /dev/null @@ -1,981 +0,0 @@ - -package IO::Compress::Base ; - -require 5.004 ; - -use strict ; -use warnings; - -use IO::Compress::Base::Common 2.021 ; - -use IO::File ; -use Scalar::Util qw(blessed readonly); - -#use File::Glob; -#require Exporter ; -use Carp ; -use Symbol; -use bytes; - -our (@ISA, $VERSION); -@ISA = qw(Exporter IO::File); - -$VERSION = '2.021'; - -#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. - -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 output -{ - my $self = shift ; - my $data = shift ; - my $last = shift ; - - return 1 - if length $data == 0 && ! $last ; - - if ( *$self->{FilterEnvelope} ) { - *_ = \$data; - &{ *$self->{FilterEnvelope} }(); - } - - if (length $data) { - if ( defined *$self->{FH} ) { - defined *$self->{FH}->write( $data, length $data ) - or return $self->saveErrorString(0, $!, $!); - } - else { - ${ *$self->{Buffer} } .= $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], - #'Encode' => [1, 1, Parse_any, undef], - 'Strict' => [0, 1, Parse_boolean, 1], - 'Append' => [1, 1, Parse_boolean, 0], - 'BinModeIn' => [1, 1, Parse_boolean, 0], - - 'FilterEnvelope' => [1, 1, Parse_any, undef], - - $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 ; - *$obj->{Append} = $appendOutput; - *$obj->{FilterEnvelope} = $got->value('FilterEnvelope') ; - - 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 - #no warnings; - #if ($outType eq 'filename' && -e $outValue && ! -w _) - # { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) } - - - - if ($got->parsed('Encode')) { - my $want_encoding = $got->value('Encode'); - *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding); - } - - $obj->ckParams($got) - or $obj->croakError("${class}: " . $obj->error()); - - - $obj->saveStatus(STATUS_OK) ; - - my $status ; - if (! $merge) - { - *$obj->{Compress} = $obj->mkComp($got) - or return undef; - - *$obj->{UnCompSize} = new U64 ; - *$obj->{CompSize} = new U64 ; - - if ( $outType eq 'buffer') { - ${ *$obj->{Buffer} } = '' - unless $appendOutput ; - } - 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') { - no warnings; - 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}) ; - } - } - - *$obj->{Header} = $obj->mkHeader($got) ; - $obj->output( *$obj->{Header} ) - or return 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 IO::Compress::Base::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, 16 * 1024)) { - $count += length $buff; - defined $self->syswrite($buff, @_) - or return undef ; - } - - return $self->saveErrorString(undef, $!, $!) - if ! defined $status ; - - 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 getFileInfo -{ -} - -sub TIEHANDLE -{ - return $_[0] if ref($_[0]); - die "OOPS\n" ; -} - -sub UNTIE -{ - my $self = shift ; -} - -sub DESTROY -{ - my $self = shift ; - local ($., $@, $!, $^E, $?); - - $self->close() ; - - # TODO - memory leak with 5.8.0 - this isn't called until - # global destruction - # - %{ *$self } = () ; - undef $self ; -} - - - -sub filterUncompressed -{ -} - -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] ; - } - - $] >= 5.008 and ( utf8::downgrade($$buffer, 1) - or croak "Wide character in " . *$self->{ClassName} . "::write:"); - - - 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 ; - - if (*$self->{Encoding}) { - $$buffer = *$self->{Encoding}->encode($$buffer); - } - - $self->filterUncompressed($buffer); - - my $buffer_length = defined $$buffer ? length($$buffer) : 0 ; - *$self->{UnCompSize}->add($buffer_length) ; - - my $outBuffer=''; - my $status = *$self->{Compress}->compr($buffer, $outBuffer) ; - - return $self->saveErrorString(undef, *$self->{Compress}{Error}, - *$self->{Compress}{ErrorNo}) - if $status == STATUS_ERROR; - - *$self->{CompSize}->add(length $outBuffer) ; - - $self->output($outBuffer) - or return undef; - - 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 $outBuffer=''; - my $status = *$self->{Compress}->flush($outBuffer, @_) ; - return $self->saveErrorString(0, *$self->{Compress}{Error}, - *$self->{Compress}{ErrorNo}) - if $status == STATUS_ERROR; - - if ( defined *$self->{FH} ) { - *$self->{FH}->clearerr(); - } - - *$self->{CompSize}->add(length $outBuffer) ; - - $self->output($outBuffer) - or return 0; - - if ( defined *$self->{FH} ) { - defined *$self->{FH}->flush() - or return $self->saveErrorString(0, $!, $!); - } - - 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->{Compress} = $self->mkComp($got) - or return 0; - - *$self->{Header} = $self->mkHeader($got) ; - $self->output(*$self->{Header} ) - or return 0; - - *$self->{UnCompSize}->reset(); - *$self->{CompSize}->reset(); - - return 1 ; -} - -sub reset -{ - my $self = shift ; - return *$self->{Compress}->reset() ; -} - -sub _writeTrailer -{ - my $self = shift ; - - my $trailer = ''; - - my $status = *$self->{Compress}->close($trailer) ; - return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) - if $status == STATUS_ERROR; - - *$self->{CompSize}->add(length $trailer) ; - - $trailer .= $self->mkTrailer(); - defined $trailer - or return 0; - - return $self->output($trailer); -} - -sub _writeFinalTrailer -{ - my $self = shift ; - - return $self->output($self->mkFinalTrailer()); -} - -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 ; - - $self->output( "", 1 ) - 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->{UnCompSize}->get32bit() ; -} - -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<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Compress/Base/Common.pm b/ext/IO-Compress/lib/IO/Compress/Base/Common.pm deleted file mode 100644 index 7981585d49..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Base/Common.pm +++ /dev/null @@ -1,956 +0,0 @@ -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, $HAS_ENCODE); -@ISA = qw(Exporter); -$VERSION = '2.021'; - -@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput - isaFileGlobString cleanFileGlobString oneTarget - setBinModeInput setBinModeOutput - ckInOutParams - createSelfTiedObject - getEncoding - - 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; - -sub hasEncode() -{ - if (! defined $HAS_ENCODE) { - eval - { - require Encode; - Encode->import(); - }; - - $HAS_ENCODE = $@ ? 0 : 1 ; - } - - return $HAS_ENCODE; -} - -sub getEncoding($$$) -{ - my $obj = shift; - my $class = shift ; - my $want_encoding = shift ; - - $obj->croakError("$class: Encode module needed to use -Encode") - if ! hasEncode(); - - my $encoding = Encode::find_encoding($want_encoding); - - $obj->croakError("$class: Encoding '$want_encoding' is not available") - if ! $encoding; - - return $encoding; -} - -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],'IO::Handle') or - UNIVERSAL::isa(\$_[0],'GLOB')) - ) -} - -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 IO::Compress::Base::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 '' ; - - if (-e $_[1]) - { - if (-d _ ) - { - return $obj->saveErrorString("output file '$_[1]' is a directory"); - } - } - } - - return $obj ; -} - -sub IO::Compress::Base::Validator::saveErrorString -{ - my $self = shift ; - ${ $self->{Error} } = shift ; - return undef; - -} - -sub IO::Compress::Base::Validator::croakError -{ - my $self = shift ; - $self->saveErrorString($_[0]); - croak $_[0]; -} - - - -sub IO::Compress::Base::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 (-d _ ) - { - return $self->saveErrorString("input file '$filename' is a directory"); - } - - if (! -r _ ) - { - return $self->saveErrorString("cannot open file '$filename': $!"); - } - } - - return 1 ; -} - -sub IO::Compress::Base::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 IO::Compress::Base::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_multiple Parse_writable_scalar - ) - ]; - -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 Parse_multiple => 0x100 ; -use constant Parse_writable => 0x200 ; -use constant Parse_writable_scalar => 0x400 | Parse_writable ; - -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 ; - - return $_[1] - if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters"); - - 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 $other; - - 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) { - if ($_[2 * $i] eq '__xxx__') { - $other = $_[2 * $i + 1] ; - } - else { - 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) { - $x = [ $x ] - if $type & Parse_multiple; - - $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ; - } - - $got->{$key}[OFF_PARSED] = 0 ; - } - - my %parsed = (); - - if ($other) - { - for my $key (keys %$default) - { - my $canonkey = lc $key; - if ($other->parsed($canonkey)) - { - my $value = $other->value($canonkey); -#print "SET '$canonkey' to $value [$$value]\n"; - ++ $parsed{$canonkey}; - $got->{$canonkey}[OFF_PARSED] = 1; - $got->{$canonkey}[OFF_DEFAULT] = $value; - $got->{$canonkey}[OFF_FIXED] = $value; - } - } - } - - 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 $parsed = $parsed{$canonkey}; - ++ $parsed{$canonkey}; - - return $self->setError("Muliple instances of '$key' found") - if $parsed && $type & Parse_multiple == 0 ; - - my $s ; - $self->_checkType($key, $value, $type, 1, \$s) - or return undef ; - - $value = $$value ; - if ($type & Parse_multiple) { - $got->{$canonkey}[OFF_PARSED] = 1; - push @{ $got->{$canonkey}[OFF_FIXED] }, $s ; - } - else { - $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_writable_scalar) - { - return $self->setError("Parameter '$key' not writable") - if $validate && readonly $$value ; - - if (ref $$value) - { - return $self->setError("Parameter '$key' not a scalar reference") - if $validate && ref $$value ne 'SCALAR' ; - - $$output = $$value ; - } - else - { - return $self->setError("Parameter '$key' not a scalar") - if $validate && ref $value ne 'SCALAR' ; - - $$output = $value ; - } - - return 1; - } - -# 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 U64; - -use constant MAX32 => 0xFFFFFFFF ; -use constant HI_1 => MAX32 + 1 ; -use constant LOW => 0 ; -use constant HIGH => 1; - -sub new -{ - my $class = shift ; - - my $high = 0 ; - my $low = 0 ; - - if (@_ == 2) { - $high = shift ; - $low = shift ; - } - elsif (@_ == 1) { - $low = shift ; - } - - bless [$low, $high], $class; -} - -sub newUnpack_V64 -{ - my $string = shift; - - my ($low, $hi) = unpack "V V", $string ; - bless [ $low, $hi ], "U64"; -} - -sub newUnpack_V32 -{ - my $string = shift; - - my $low = unpack "V", $string ; - bless [ $low, 0 ], "U64"; -} - -sub reset -{ - my $self = shift; - $self->[HIGH] = $self->[LOW] = 0; -} - -sub clone -{ - my $self = shift; - bless [ @$self ], ref $self ; -} - -sub getHigh -{ - my $self = shift; - return $self->[HIGH]; -} - -sub getLow -{ - my $self = shift; - return $self->[LOW]; -} - -sub get32bit -{ - my $self = shift; - return $self->[LOW]; -} - -sub get64bit -{ - my $self = shift; - # Not using << here because the result will still be - # a 32-bit value on systems where int size is 32-bits - return $self->[HIGH] * HI_1 + $self->[LOW]; -} - -sub add -{ - my $self = shift; - my $value = shift; - - if (ref $value eq 'U64') { - $self->[HIGH] += $value->[HIGH] ; - $value = $value->[LOW]; - } - - my $available = MAX32 - $self->[LOW] ; - - if ($value > $available) { - ++ $self->[HIGH] ; - $self->[LOW] = $value - $available - 1; - } - else { - $self->[LOW] += $value ; - } - -} - -sub equal -{ - my $self = shift; - my $other = shift; - - return $self->[LOW] == $other->[LOW] && - $self->[HIGH] == $other->[HIGH] ; -} - -sub is64bit -{ - my $self = shift; - return $self->[HIGH] > 0 ; -} - -sub getPacked_V64 -{ - my $self = shift; - - return pack "V V", @$self ; -} - -sub getPacked_V32 -{ - my $self = shift; - - return pack "V", $self->[LOW] ; -} - -sub pack_V64 -{ - my $low = shift; - - return pack "V V", $low, 0; -} - - -package IO::Compress::Base::Common; - -1; diff --git a/ext/IO-Compress/lib/IO/Compress/Bzip2.pm b/ext/IO-Compress/lib/IO/Compress/Bzip2.pm deleted file mode 100644 index e5f86b2f36..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Bzip2.pm +++ /dev/null @@ -1,758 +0,0 @@ -package IO::Compress::Bzip2 ; - -use strict ; -use warnings; -use bytes; -require Exporter ; - -use IO::Compress::Base 2.021 ; - -use IO::Compress::Base::Common 2.021 qw(createSelfTiedObject); -use IO::Compress::Adapter::Bzip2 2.021 ; - - - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error); - -$VERSION = '2.021'; -$Bzip2Error = ''; - -@ISA = qw(Exporter IO::Compress::Base); -@EXPORT_OK = qw( $Bzip2Error bzip2 ) ; -%EXPORT_TAGS = %IO::Compress::Base::EXPORT_TAGS ; -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; -Exporter::export_ok_tags('all'); - - - -sub new -{ - my $class = shift ; - - my $obj = createSelfTiedObject($class, \$Bzip2Error); - return $obj->_create(undef, @_); -} - -sub bzip2 -{ - my $obj = createSelfTiedObject(undef, \$Bzip2Error); - $obj->_def(@_); -} - - -sub mkHeader -{ - my $self = shift ; - return ''; - -} - -sub getExtraParams -{ - my $self = shift ; - - use IO::Compress::Base::Common 2.021 qw(:Parse); - - return ( - 'BlockSize100K' => [0, 1, Parse_unsigned, 1], - 'WorkFactor' => [0, 1, Parse_unsigned, 0], - 'Verbosity' => [0, 1, Parse_boolean, 0], - ); -} - - - -sub ckParams -{ - my $self = shift ; - my $got = shift; - - # check that BlockSize100K is a number between 1 & 9 - if ($got->parsed('BlockSize100K')) { - my $value = $got->value('BlockSize100K'); - return $self->saveErrorString(undef, "Parameter 'BlockSize100K' not between 1 and 9, got $value") - unless defined $value && $value >= 1 && $value <= 9; - - } - - # check that WorkFactor between 0 & 250 - if ($got->parsed('WorkFactor')) { - my $value = $got->value('WorkFactor'); - return $self->saveErrorString(undef, "Parameter 'WorkFactor' not between 0 and 250, got $value") - unless $value >= 0 && $value <= 250; - } - - return 1 ; -} - - -sub mkComp -{ - my $self = shift ; - my $got = shift ; - - my $BlockSize100K = $got->value('BlockSize100K'); - my $WorkFactor = $got->value('WorkFactor'); - my $Verbosity = $got->value('Verbosity'); - - my ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject( - $BlockSize100K, $WorkFactor, - $Verbosity); - - return $self->saveErrorString(undef, $errstr, $errno) - if ! defined $obj; - - return $obj; -} - - -sub mkTrailer -{ - my $self = shift ; - return ''; -} - -sub mkFinalTrailer -{ - return ''; -} - -#sub newHeader -#{ -# my $self = shift ; -# return ''; -#} - -sub getInverseClass -{ - return ('IO::Uncompress::Bunzip2'); -} - -sub getFileInfo -{ - my $self = shift ; - my $params = shift; - my $file = shift ; - -} - -1; - -__END__ - -=head1 NAME - -IO::Compress::Bzip2 - Write bzip2 files/buffers - - - -=head1 SYNOPSIS - - use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; - - my $status = bzip2 $input => $output [,OPTS] - or die "bzip2 failed: $Bzip2Error\n"; - - my $z = new IO::Compress::Bzip2 $output [,OPTS] - or die "bzip2 failed: $Bzip2Error\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->close() ; - - $Bzip2Error ; - - # 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 - -This module provides a Perl interface that allows writing bzip2 -compressed data to files or buffer. - -For reading bzip2 files/buffers, see the companion module -L<IO::Uncompress::Bunzip2|IO::Uncompress::Bunzip2>. - -=head1 Functional Interface - -A top-level function, C<bzip2>, is provided to carry out -"one-shot" compression between buffers and/or files. For finer -control over the compression process, see the L</"OO Interface"> -section. - - use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; - - bzip2 $input => $output [,OPTS] - or die "bzip2 failed: $Bzip2Error\n"; - -The functional interface needs Perl5.005 or better. - -=head2 bzip2 $input => $output [, OPTS] - -C<bzip2> 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<bzip2> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -compressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the compressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the compressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the compressed data will be -stored in C<$$output>. - -=item 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<bzip2> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the input files/buffers will be stored -in C<$output> as a concatenated series of compressed data streams. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<bzip2>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<bzip2> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<bzip2> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeIn => 0|1 >> - -When reading from a file or filehandle, set C<binmode> before reading. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt> and write the compressed -data to the file C<file1.txt.bz2>. - - use strict ; - use warnings ; - use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; - - my $input = "file1.txt"; - bzip2 $input => "$input.bz2" - or die "bzip2 failed: $Bzip2Error\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::Bzip2 qw(bzip2 $Bzip2Error) ; - use IO::File ; - - my $input = new IO::File "<file1.txt" - or die "Cannot open 'file1.txt': $!\n" ; - my $buffer ; - bzip2 $input => \$buffer - or die "bzip2 failed: $Bzip2Error\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::Bzip2 qw(bzip2 $Bzip2Error) ; - - bzip2 '</my/home/*.txt>' => '<*.bz2>' - or die "bzip2 failed: $Bzip2Error\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::Bzip2 qw(bzip2 $Bzip2Error) ; - - for my $input ( glob "/my/home/*.txt" ) - { - my $output = "$input.bz2" ; - bzip2 $input => $output - or die "Error compressing '$input': $Bzip2Error\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for C<IO::Compress::Bzip2> is shown below - - my $z = new IO::Compress::Bzip2 $output [,OPTS] - or die "IO::Compress::Bzip2 failed: $Bzip2Error\n"; - -It returns an C<IO::Compress::Bzip2> object on success and undef on failure. -The variable C<$Bzip2Error> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Compress::Bzip2 can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal output file operations can be carried out -with C<$z>. -For example, to write to a compressed file/buffer you can use either of -these forms - - $z->print("hello world\n"); - print $z "hello world\n"; - -The mandatory parameter C<$output> is used to control the destination -of the compressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the compressed data -will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the compressed data will be -written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the compressed data will be stored -in C<$$output>. - -=back - -If the C<$output> parameter is any other type, C<IO::Compress::Bzip2>::new will -return undef. - -=head2 Constructor Options - -C<OPTS> is any combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$output> parameter is a filehandle. If -specified, and the value is true, it will result in the C<$output> being -closed once either the C<close> method is called or the C<IO::Compress::Bzip2> -object is destroyed. - -This parameter defaults to 0. - -=item C<< Append => 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<Append> is enabled, all compressed data -will be append to the end if C<$output>. Otherwise C<$output> will be -cleared before any data is written to it. - -=item * A Filename - -If C<$output> is a filename and C<Append> is enabled, the file will be -opened in append mode. Otherwise the contents of the file, if any, will be -truncated before any compressed data is written to it. - -=item * A Filehandle - -If C<$output> is a filehandle, the file pointer will be positioned to the -end of the file via a call to C<seek> before any compressed data is written -to it. Otherwise the file pointer will not be moved. - -=back - -This parameter defaults to 0. - -=item C<< BlockSize100K => number >> - -Specify the number of 100K blocks bzip2 uses during compression. - -Valid values are from 1 to 9, where 9 is best compression. - -The default is 1. - -=item C<< WorkFactor => number >> - -Specifies how much effort bzip2 should take before resorting to a slower -fallback compression algorithm. - -Valid values range from 0 to 250, where 0 means use the default value 30. - -The default is 0. - -=item C<< Strict => 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<print> built-in. - -Returns true if successful. - -=head2 printf - -Usage is - - $z->printf($format, $data) - printf $z $format, $data - -Compresses and outputs the contents of the C<$data> parameter. - -Returns true if successful. - -=head2 syswrite - -Usage is - - $z->syswrite $data - $z->syswrite $data, $length - $z->syswrite $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 write - -Usage is - - $z->write $data - $z->write $data, $length - $z->write $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 flush - -Usage is - - $z->flush; - -Flushes any pending compressed data to the output file/buffer. - -TODO - -Returns true on success. - -=head2 tell - -Usage is - - $z->tell() - tell $z - -Returns the uncompressed file offset. - -=head2 eof - -Usage is - - $z->eof(); - eof($z); - -Returns true if the C<close> method has been called. - -=head2 seek - - $z->seek($position, $whence); - seek($z, $position, $whence); - -Provides a sub-set of the C<seek> functionality, with the restriction -that it is only legal to seek forward in the output file/buffer. -It is a fatal error to attempt to seek backward. - -Empty parts of the file/buffer will have NULL (0x00) bytes written to them. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<undef> when compressing. - -=head2 fileno - - $z->fileno() - fileno($z) - -If the C<$z> object is associated with a file or a filehandle, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<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::Bzip2 object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Compress::Bzip2 -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 any of the the options that are available when creating -the C<$z> object. - -See the L</"Constructor Options"> section for more details. - -=head1 Importing - -No symbolic constants are required by this IO::Compress::Bzip2 at present. - -=over 5 - -=item :all - -Imports C<bzip2> and C<$Bzip2Error>. -Same as doing this - - use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; - - - -=back - -=head1 EXAMPLES - -=head2 Apache::GZip Revisited - -See L<IO::Compress::Bzip2::FAQ|IO::Compress::Bzip2::FAQ/"Apache::GZip Revisited"> - - - -=head2 Working with Net::FTP - -See L<IO::Compress::Bzip2::FAQ|IO::Compress::Bzip2::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -The primary site for the bzip2 program is F<http://www.bzip.org>. - -See the module L<Compress::Bzip2|Compress::Bzip2> - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2008 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/IO-Compress/lib/IO/Compress/Deflate.pm b/ext/IO-Compress/lib/IO/Compress/Deflate.pm deleted file mode 100644 index 7ee0a53997..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Deflate.pm +++ /dev/null @@ -1,889 +0,0 @@ -package IO::Compress::Deflate ; - -use strict ; -use warnings; -use bytes; - -require Exporter ; - -use IO::Compress::RawDeflate 2.021 ; - -use Compress::Raw::Zlib 2.021 ; -use IO::Compress::Zlib::Constants 2.021 ; -use IO::Compress::Base::Common 2.021 qw(createSelfTiedObject); - - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError); - -$VERSION = '2.021'; -$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 - 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 - -This module provides a Perl interface that allows writing compressed -data to files or buffer as defined in RFC 1950. - -For reading RFC 1950 files/buffers, see the companion module -L<IO::Uncompress::Inflate|IO::Uncompress::Inflate>. - -=head1 Functional Interface - -A top-level function, C<deflate>, is provided to carry out -"one-shot" compression between buffers and/or files. For finer -control over the compression process, see the L</"OO Interface"> -section. - - use IO::Compress::Deflate qw(deflate $DeflateError) ; - - deflate $input => $output [,OPTS] - or die "deflate failed: $DeflateError\n"; - -The functional interface needs Perl5.005 or better. - -=head2 deflate $input => $output [, OPTS] - -C<deflate> expects at least two parameters, C<$input> and C<$output>. - -=head3 The C<$input> parameter - -The parameter, C<$input>, is used to define the source of -the uncompressed data. - -It can take one of the following forms: - -=over 5 - -=item A filename - -If the C<$input> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for reading and the input data -will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the input data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the input data will be read -from C<$$input>. - -=item An array reference - -If C<$input> is an array reference, 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<deflate> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -compressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the compressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the compressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the compressed data will be -stored in C<$$output>. - -=item An Array Reference - -If C<$output> is an array reference, the compressed data will be -pushed onto the array. - -=item An Output FileGlob - -If C<$output> is a string that is delimited by the characters "<" and ">" -C<deflate> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the input files/buffers will be stored -in C<$output> as a concatenated series of compressed data streams. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<deflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<deflate> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<deflate> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeIn => 0|1 >> - -When reading from a file or filehandle, set C<binmode> before reading. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt> and write the compressed -data to the file C<file1.txt.1950>. - - use strict ; - use warnings ; - use IO::Compress::Deflate qw(deflate $DeflateError) ; - - my $input = "file1.txt"; - deflate $input => "$input.1950" - or die "deflate failed: $DeflateError\n"; - -To read from an existing Perl filehandle, C<$input>, and write the -compressed data to a buffer, C<$buffer>. - - use strict ; - use warnings ; - use IO::Compress::Deflate qw(deflate $DeflateError) ; - use IO::File ; - - my $input = new IO::File "<file1.txt" - or die "Cannot open 'file1.txt': $!\n" ; - my $buffer ; - deflate $input => \$buffer - or die "deflate failed: $DeflateError\n"; - -To compress all files in the directory "/my/home" that match "*.txt" -and store the compressed data in the same directory - - use strict ; - use warnings ; - use IO::Compress::Deflate qw(deflate $DeflateError) ; - - deflate '</my/home/*.txt>' => '<*.1950>' - or die "deflate failed: $DeflateError\n"; - -and if you want to compress each file one at a time, this will do the trick - - use strict ; - use warnings ; - use IO::Compress::Deflate qw(deflate $DeflateError) ; - - for my $input ( glob "/my/home/*.txt" ) - { - my $output = "$input.1950" ; - deflate $input => $output - or die "Error compressing '$input': $DeflateError\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for C<IO::Compress::Deflate> is shown below - - my $z = new IO::Compress::Deflate $output [,OPTS] - or die "IO::Compress::Deflate failed: $DeflateError\n"; - -It returns an C<IO::Compress::Deflate> object on success and undef on failure. -The variable C<$DeflateError> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Compress::Deflate can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal output file operations can be carried out -with C<$z>. -For example, to write to a compressed file/buffer you can use either of -these forms - - $z->print("hello world\n"); - print $z "hello world\n"; - -The mandatory parameter C<$output> is used to control the destination -of the compressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the compressed data -will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the compressed data will be -written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the compressed data will be stored -in C<$$output>. - -=back - -If the C<$output> parameter is any other type, C<IO::Compress::Deflate>::new will -return undef. - -=head2 Constructor Options - -C<OPTS> is any combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$output> parameter is a filehandle. If -specified, and the value is true, it will result in the C<$output> being -closed once either the C<close> method is called or the C<IO::Compress::Deflate> -object is destroyed. - -This parameter defaults to 0. - -=item C<< Append => 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<Append> is enabled, all compressed data -will be append to the end if C<$output>. Otherwise C<$output> will be -cleared before any data is written to it. - -=item * A Filename - -If C<$output> is a filename and C<Append> is enabled, the file will be -opened in append mode. Otherwise the contents of the file, if any, will be -truncated before any compressed data is written to it. - -=item * A Filehandle - -If C<$output> is a filehandle, the file pointer will be positioned to the -end of the file via a call to C<seek> before any compressed data is written -to it. Otherwise the file pointer will not be moved. - -=back - -This parameter defaults to 0. - -=item C<< Merge => 0|1 >> - -This option is used to compress input data and append it to an existing -compressed data stream in C<$output>. The end result is a single compressed -data stream stored in C<$output>. - -It is a fatal error to attempt to use this option when C<$output> is not an -RFC 1950 data stream. - -There are a number of other limitations with the C<Merge> option: - -=over 5 - -=item 1 - -This module needs to have been built with zlib 1.2.1 or better to work. A -fatal error will be thrown if C<Merge> is used with an older version of -zlib. - -=item 2 - -If C<$output> is a file or a filehandle, it must be seekable. - -=back - -This parameter defaults to 0. - -=item -Level - -Defines the compression level used by zlib. The value should either be -a number between 0 and 9 (0 means no compression and 9 is maximum -compression), or one of the symbolic constants defined below. - - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - -The default is Z_DEFAULT_COMPRESSION. - -Note, these constants are not imported by C<IO::Compress::Deflate> by default. - - use IO::Compress::Deflate qw(:strategy); - use IO::Compress::Deflate qw(:constants); - use IO::Compress::Deflate qw(:all); - -=item -Strategy - -Defines the strategy used to tune the compression. Use one of the symbolic -constants defined below. - - Z_FILTERED - Z_HUFFMAN_ONLY - Z_RLE - Z_FIXED - Z_DEFAULT_STRATEGY - -The default is Z_DEFAULT_STRATEGY. - -=item C<< Strict => 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<print> built-in. - -Returns true if successful. - -=head2 printf - -Usage is - - $z->printf($format, $data) - printf $z $format, $data - -Compresses and outputs the contents of the C<$data> parameter. - -Returns true if successful. - -=head2 syswrite - -Usage is - - $z->syswrite $data - $z->syswrite $data, $length - $z->syswrite $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 write - -Usage is - - $z->write $data - $z->write $data, $length - $z->write $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 flush - -Usage is - - $z->flush; - $z->flush($flush_type); - -Flushes any pending compressed data to the output file/buffer. - -This method takes an optional parameter, C<$flush_type>, that controls -how the flushing will be carried out. By default the C<$flush_type> -used is C<Z_FINISH>. Other valid values for C<$flush_type> are -C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is -strongly recommended that you only set the C<flush_type> parameter if -you fully understand the implications of what it does - overuse of C<flush> -can seriously degrade the level of compression achieved. See the C<zlib> -documentation for details. - -Returns true on success. - -=head2 tell - -Usage is - - $z->tell() - tell $z - -Returns the uncompressed file offset. - -=head2 eof - -Usage is - - $z->eof(); - eof($z); - -Returns true if the C<close> method has been called. - -=head2 seek - - $z->seek($position, $whence); - seek($z, $position, $whence); - -Provides a sub-set of the C<seek> functionality, with the restriction -that it is only legal to seek forward in the output file/buffer. -It is a fatal error to attempt to seek backward. - -Empty parts of the file/buffer will have NULL (0x00) bytes written to them. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<undef> when compressing. - -=head2 fileno - - $z->fileno() - fileno($z) - -If the C<$z> object is associated with a file or a filehandle, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<undef>. - -=head2 close - - $z->close() ; - close $z ; - -Flushes any pending compressed data and then closes the output file/buffer. - -For most versions of Perl this method will be automatically invoked if -the IO::Compress::Deflate object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Compress::Deflate -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 newStream([OPTS]) - -Usage is - - $z->newStream( [OPTS] ) - -Closes the current compressed data stream and starts a new one. - -OPTS consists of any of the the options that are available when creating -the C<$z> object. - -See the L</"Constructor Options"> section for more details. - -=head2 deflateParams - -Usage is - - $z->deflateParams - -TODO - -=head1 Importing - -A number of symbolic constants are required by some methods in -C<IO::Compress::Deflate>. None are imported by default. - -=over 5 - -=item :all - -Imports C<deflate>, C<$DeflateError> and all symbolic -constants that can be used by C<IO::Compress::Deflate>. Same as doing this - - use IO::Compress::Deflate qw(deflate $DeflateError :constants) ; - -=item :constants - -Import all symbolic constants. Same as doing this - - use IO::Compress::Deflate qw(:flush :level :strategy) ; - -=item :flush - -These symbolic constants are used by the C<flush> method. - - Z_NO_FLUSH - Z_PARTIAL_FLUSH - Z_SYNC_FLUSH - Z_FULL_FLUSH - Z_FINISH - Z_BLOCK - -=item :level - -These symbolic constants are used by the C<Level> option in the constructor. - - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - -=item :strategy - -These symbolic constants are used by the C<Strategy> option in the constructor. - - Z_FILTERED - Z_HUFFMAN_ONLY - Z_RLE - Z_FIXED - Z_DEFAULT_STRATEGY - - - - -=back - -=head1 EXAMPLES - -=head2 Apache::GZip Revisited - -See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> - - - -=head2 Working with Net::FTP - -See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Compress/Gzip.pm b/ext/IO-Compress/lib/IO/Compress/Gzip.pm deleted file mode 100644 index 5ddfad20b9..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Gzip.pm +++ /dev/null @@ -1,1201 +0,0 @@ - -package IO::Compress::Gzip ; - -require 5.004 ; - -use strict ; -use warnings; -use bytes; - - -use IO::Compress::RawDeflate 2.021 ; - -use Compress::Raw::Zlib 2.021 ; -use IO::Compress::Base::Common 2.021 qw(:Status :Parse createSelfTiedObject); -use IO::Compress::Gzip::Constants 2.021 ; -use IO::Compress::Zlib::Extra 2.021 ; - -BEGIN -{ - if (defined &utf8::downgrade ) - { *noUTF8 = \&utf8::downgrade } - else - { *noUTF8 = sub {} } -} - -require Exporter ; - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError); - -$VERSION = '2.021'; -$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_any, 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 $strict = $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 $strict && $name =~ /\x00/ ; - - return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Name", - Z_DATA_ERROR) - if $strict && $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 $strict && $comment =~ /\x00/ ; - - return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment", - Z_DATA_ERROR) - if $strict && $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 ; - } - - my $data = $got->value('ExtraField') ; - if (defined $data) { - my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, $strict, 1) ; - return $self->saveErrorString(undef, "Error with ExtraField Parameter: $bad", Z_DATA_ERROR) - if $bad ; - - $got->value('ExtraField', $data) ; - } - } - - return 1; -} - -sub mkTrailer -{ - my $self = shift ; - return pack("V V", *$self->{Compress}->crc32(), - *$self->{UnCompSize}->get32bit()); -} - -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 mkFinalTrailer -{ - return ''; -} - -1; - -__END__ - -=head1 NAME - -IO::Compress::Gzip - 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 - -This module provides a Perl interface that allows writing compressed -data to files or buffer as defined in RFC 1952. - -All the gzip headers defined in RFC 1952 can be created using -this module. - -For reading RFC 1952 files/buffers, see the companion module -L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>. - -=head1 Functional Interface - -A top-level function, C<gzip>, is provided to carry out -"one-shot" compression between buffers and/or files. For finer -control over the compression process, see the L</"OO Interface"> -section. - - use IO::Compress::Gzip qw(gzip $GzipError) ; - - gzip $input => $output [,OPTS] - or die "gzip failed: $GzipError\n"; - -The functional interface needs Perl5.005 or better. - -=head2 gzip $input => $output [, OPTS] - -C<gzip> expects at least two parameters, C<$input> and C<$output>. - -=head3 The C<$input> parameter - -The parameter, C<$input>, is used to define the source of -the uncompressed data. - -It can take one of the following forms: - -=over 5 - -=item A filename - -If the C<$input> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for reading and the input data -will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the input data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the input data will be read -from C<$$input>. - -=item An array reference - -If C<$input> is an array reference, 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<gzip> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -In addition, if C<$input> is a simple filename, the default values for -the C<Name> and C<Time> options will be sourced from that file. - -If you do not want to use these defaults they can be overridden by -explicitly setting the C<Name> and C<Time> options or by setting the -C<Minimal> parameter. - -=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<gzip> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the input files/buffers will be stored -in C<$output> as a concatenated series of compressed data streams. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<gzip>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<gzip> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<gzip> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeIn => 0|1 >> - -When reading from a file or filehandle, set C<binmode> before reading. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt> and write the compressed -data to the file C<file1.txt.gz>. - - use strict ; - use warnings ; - use IO::Compress::Gzip qw(gzip $GzipError) ; - - my $input = "file1.txt"; - gzip $input => "$input.gz" - or die "gzip failed: $GzipError\n"; - -To read from an existing Perl filehandle, C<$input>, and write the -compressed data to a buffer, C<$buffer>. - - use strict ; - use warnings ; - use IO::Compress::Gzip qw(gzip $GzipError) ; - use IO::File ; - - my $input = new IO::File "<file1.txt" - or die "Cannot open 'file1.txt': $!\n" ; - my $buffer ; - gzip $input => \$buffer - or die "gzip failed: $GzipError\n"; - -To compress all files in the directory "/my/home" that match "*.txt" -and store the compressed data in the same directory - - use strict ; - use warnings ; - use IO::Compress::Gzip qw(gzip $GzipError) ; - - gzip '</my/home/*.txt>' => '<*.gz>' - or die "gzip failed: $GzipError\n"; - -and if you want to compress each file one at a time, this will do the trick - - use strict ; - use warnings ; - use IO::Compress::Gzip qw(gzip $GzipError) ; - - for my $input ( glob "/my/home/*.txt" ) - { - my $output = "$input.gz" ; - gzip $input => $output - or die "Error compressing '$input': $GzipError\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for C<IO::Compress::Gzip> is shown below - - my $z = new IO::Compress::Gzip $output [,OPTS] - or die "IO::Compress::Gzip failed: $GzipError\n"; - -It returns an C<IO::Compress::Gzip> object on success and undef on failure. -The variable C<$GzipError> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Compress::Gzip can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal output file operations can be carried out -with C<$z>. -For example, to write to a compressed file/buffer you can use either of -these forms - - $z->print("hello world\n"); - print $z "hello world\n"; - -The mandatory parameter C<$output> is used to control the destination -of the compressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the compressed data -will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the compressed data will be -written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the compressed data will be stored -in C<$$output>. - -=back - -If the C<$output> parameter is any other type, C<IO::Compress::Gzip>::new will -return undef. - -=head2 Constructor Options - -C<OPTS> is any combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$output> parameter is a filehandle. If -specified, and the value is true, it will result in the C<$output> being -closed once either the C<close> method is called or the C<IO::Compress::Gzip> -object is destroyed. - -This parameter defaults to 0. - -=item C<< Append => 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<Append> is enabled, all compressed data -will be append to the end if C<$output>. Otherwise C<$output> will be -cleared before any data is written to it. - -=item * A Filename - -If C<$output> is a filename and C<Append> is enabled, the file will be -opened in append mode. Otherwise the contents of the file, if any, will be -truncated before any compressed data is written to it. - -=item * A Filehandle - -If C<$output> is a filehandle, the file pointer will be positioned to the -end of the file via a call to C<seek> before any compressed data is written -to it. Otherwise the file pointer will not be moved. - -=back - -This parameter defaults to 0. - -=item C<< Merge => 0|1 >> - -This option is used to compress input data and append it to an existing -compressed data stream in C<$output>. The end result is a single compressed -data stream stored in C<$output>. - -It is a fatal error to attempt to use this option when C<$output> is not an -RFC 1952 data stream. - -There are a number of other limitations with the C<Merge> option: - -=over 5 - -=item 1 - -This module needs to have been built with zlib 1.2.1 or better to work. A -fatal error will be thrown if C<Merge> is used with an older version of -zlib. - -=item 2 - -If C<$output> is a file or a filehandle, it must be seekable. - -=back - -This parameter defaults to 0. - -=item -Level - -Defines the compression level used by zlib. The value should either be -a number between 0 and 9 (0 means no compression and 9 is maximum -compression), or one of the symbolic constants defined below. - - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - -The default is Z_DEFAULT_COMPRESSION. - -Note, these constants are not imported by C<IO::Compress::Gzip> by default. - - use IO::Compress::Gzip qw(:strategy); - use IO::Compress::Gzip qw(:constants); - use IO::Compress::Gzip qw(:all); - -=item -Strategy - -Defines the strategy used to tune the compression. Use one of the symbolic -constants defined below. - - Z_FILTERED - Z_HUFFMAN_ONLY - Z_RLE - Z_FIXED - Z_DEFAULT_STRATEGY - -The default is Z_DEFAULT_STRATEGY. - -=item C<< Minimal => 0|1 >> - -If specified, this option will force the creation of the smallest possible -compliant gzip header (which is exactly 10 bytes long) as defined in -RFC 1952. - -See the section titled "Compliance" in RFC 1952 for a definition -of the values used for the fields in the gzip header. - -All other parameters that control the content of the gzip header will -be ignored if this parameter is set to 1. - -This parameter defaults to 0. - -=item C<< Comment => $comment >> - -Stores the contents of C<$comment> in the COMMENT field in -the gzip header. -By default, no comment field is written to the gzip file. - -If the C<-Strict> option is enabled, the comment can only consist of ISO -8859-1 characters plus line feed. - -If the C<-Strict> option is disabled, the comment field can contain any -character except NULL. If any null characters are present, the field -will be truncated at the first NULL. - -=item C<< Name => $string >> - -Stores the contents of C<$string> in the gzip NAME header field. If -C<Name> is not specified, no gzip NAME field will be created. - -If the C<-Strict> option is enabled, C<$string> can only consist of ISO -8859-1 characters. - -If C<-Strict> is disabled, then C<$string> can contain any character -except NULL. If any null characters are present, the field will be -truncated at the first NULL. - -=item C<< Time => $number >> - -Sets the MTIME field in the gzip header to $number. - -This field defaults to the time the C<IO::Compress::Gzip> object was created -if this option is not specified. - -=item C<< TextFlag => 0|1 >> - -This parameter controls the setting of the FLG.FTEXT bit in the gzip -header. It is used to signal that the data stored in the gzip file/buffer -is probably text. - -The default is 0. - -=item C<< HeaderCRC => 0|1 >> - -When true this parameter will set the FLG.FHCRC bit to 1 in the gzip header -and set the CRC16 header field to the CRC of the complete gzip header -except the CRC16 field itself. - -B<Note> that gzip files created with the C<HeaderCRC> flag set to 1 cannot -be read by most, if not all, of the the standard gunzip utilities, most -notably gzip version 1.2.4. You should therefore avoid using this option if -you want to maximize the portability of your gzip files. - -This parameter defaults to 0. - -=item C<< OS_Code => $value >> - -Stores C<$value> in the gzip OS header field. A number between 0 and 255 is -valid. - -If not specified, this parameter defaults to the OS code of the Operating -System this module was built on. The value 3 is used as a catch-all for all -Unix variants and unknown Operating Systems. - -=item C<< ExtraField => $data >> - -This parameter allows additional metadata to be stored in the ExtraField in -the gzip header. An RFC 1952 compliant ExtraField consists of zero or more -subfields. Each subfield consists of a two byte header followed by the -subfield data. - -The list of subfields can be supplied in any of the following formats - - -ExtraField => [$id1, $data1, - $id2, $data2, - ... - ] - -ExtraField => [ [$id1 => $data1], - [$id2 => $data2], - ... - ] - -ExtraField => { $id1 => $data1, - $id2 => $data2, - ... - } - -Where C<$id1>, C<$id2> are two byte subfield ID's. The second byte of -the ID cannot be 0, unless the C<Strict> option has been disabled. - -If you use the hash syntax, you have no control over the order in which -the ExtraSubFields are stored, plus you cannot have SubFields with -duplicate ID. - -Alternatively the list of subfields can by supplied as a scalar, thus - - -ExtraField => $rawdata - -If you use the raw format, and the C<Strict> option is enabled, -C<IO::Compress::Gzip> will check that C<$rawdata> consists of zero or more -conformant sub-fields. When C<Strict> is disabled, C<$rawdata> can -consist of any arbitrary byte stream. - -The maximum size of the Extra Field 65535 bytes. - -=item C<< ExtraFlags => $value >> - -Sets the XFL byte in the gzip header to C<$value>. - -If this option is not present, the value stored in XFL field will be -determined by the setting of the C<Level> option. - -If C<< Level => Z_BEST_SPEED >> has been specified then XFL is set to 2. -If C<< Level => Z_BEST_COMPRESSION >> has been specified then XFL is set to 4. -Otherwise XFL is set to 0. - -=item C<< Strict => 0|1 >> - -C<Strict> will optionally police the values supplied with other options -to ensure they are compliant with RFC1952. - -This option is enabled by default. - -If C<Strict> is enabled the following behaviour will be policed: - -=over 5 - -=item * - -The value supplied with the C<Name> option can only contain ISO 8859-1 -characters. - -=item * - -The value supplied with the C<Comment> option can only contain ISO 8859-1 -characters plus line-feed. - -=item * - -The values supplied with the C<-Name> and C<-Comment> options cannot -contain multiple embedded nulls. - -=item * - -If an C<ExtraField> option is specified and it is a simple scalar, -it must conform to the sub-field structure as defined in RFC 1952. - -=item * - -If an C<ExtraField> option is specified the second byte of the ID will be -checked in each subfield to ensure that it does not contain the reserved -value 0x00. - -=back - -When C<Strict> is disabled the following behaviour will be policed: - -=over 5 - -=item * - -The value supplied with C<-Name> option can contain -any character except NULL. - -=item * - -The value supplied with C<-Comment> option can contain any character -except NULL. - -=item * - -The values supplied with the C<-Name> and C<-Comment> options can contain -multiple embedded nulls. The string written to the gzip header will -consist of the characters up to, but not including, the first embedded -NULL. - -=item * - -If an C<ExtraField> option is specified and it is a simple scalar, the -structure will not be checked. The only error is if the length is too big. - -=item * - -The ID header in an C<ExtraField> sub-field can consist of any two bytes. - -=back - -=back - -=head2 Examples - -TODO - -=head1 Methods - -=head2 print - -Usage is - - $z->print($data) - print $z $data - -Compresses and outputs the contents of the C<$data> parameter. This -has the same behaviour as the C<print> built-in. - -Returns true if successful. - -=head2 printf - -Usage is - - $z->printf($format, $data) - printf $z $format, $data - -Compresses and outputs the contents of the C<$data> parameter. - -Returns true if successful. - -=head2 syswrite - -Usage is - - $z->syswrite $data - $z->syswrite $data, $length - $z->syswrite $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 write - -Usage is - - $z->write $data - $z->write $data, $length - $z->write $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 flush - -Usage is - - $z->flush; - $z->flush($flush_type); - -Flushes any pending compressed data to the output file/buffer. - -This method takes an optional parameter, C<$flush_type>, that controls -how the flushing will be carried out. By default the C<$flush_type> -used is C<Z_FINISH>. Other valid values for C<$flush_type> are -C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is -strongly recommended that you only set the C<flush_type> parameter if -you fully understand the implications of what it does - overuse of C<flush> -can seriously degrade the level of compression achieved. See the C<zlib> -documentation for details. - -Returns true on success. - -=head2 tell - -Usage is - - $z->tell() - tell $z - -Returns the uncompressed file offset. - -=head2 eof - -Usage is - - $z->eof(); - eof($z); - -Returns true if the C<close> method has been called. - -=head2 seek - - $z->seek($position, $whence); - seek($z, $position, $whence); - -Provides a sub-set of the C<seek> functionality, with the restriction -that it is only legal to seek forward in the output file/buffer. -It is a fatal error to attempt to seek backward. - -Empty parts of the file/buffer will have NULL (0x00) bytes written to them. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<undef> when compressing. - -=head2 fileno - - $z->fileno() - fileno($z) - -If the C<$z> object is associated with a file or a filehandle, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<undef>. - -=head2 close - - $z->close() ; - close $z ; - -Flushes any pending compressed data and then closes the output file/buffer. - -For most versions of Perl this method will be automatically invoked if -the IO::Compress::Gzip object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Compress::Gzip -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 newStream([OPTS]) - -Usage is - - $z->newStream( [OPTS] ) - -Closes the current compressed data stream and starts a new one. - -OPTS consists of any of the the options that are available when creating -the C<$z> object. - -See the L</"Constructor Options"> section for more details. - -=head2 deflateParams - -Usage is - - $z->deflateParams - -TODO - -=head1 Importing - -A number of symbolic constants are required by some methods in -C<IO::Compress::Gzip>. None are imported by default. - -=over 5 - -=item :all - -Imports C<gzip>, C<$GzipError> and all symbolic -constants that can be used by C<IO::Compress::Gzip>. Same as doing this - - use IO::Compress::Gzip qw(gzip $GzipError :constants) ; - -=item :constants - -Import all symbolic constants. Same as doing this - - use IO::Compress::Gzip qw(:flush :level :strategy) ; - -=item :flush - -These symbolic constants are used by the C<flush> method. - - Z_NO_FLUSH - Z_PARTIAL_FLUSH - Z_SYNC_FLUSH - Z_FULL_FLUSH - Z_FINISH - Z_BLOCK - -=item :level - -These symbolic constants are used by the C<Level> option in the constructor. - - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - -=item :strategy - -These symbolic constants are used by the C<Strategy> option in the constructor. - - Z_FILTERED - Z_HUFFMAN_ONLY - Z_RLE - Z_FIXED - Z_DEFAULT_STRATEGY - - - - -=back - -=head1 EXAMPLES - -=head2 Apache::GZip Revisited - -See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> - - - -=head2 Working with Net::FTP - -See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Compress/Gzip/Constants.pm b/ext/IO-Compress/lib/IO/Compress/Gzip/Constants.pm deleted file mode 100644 index 826183680e..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Gzip/Constants.pm +++ /dev/null @@ -1,148 +0,0 @@ -package IO::Compress::Gzip::Constants; - -use strict ; -use warnings; -use bytes; - -require Exporter; - -our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); -our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE); - -$VERSION = '2.021'; - -@ISA = qw(Exporter); - -@EXPORT= qw( - - GZIP_ID_SIZE - GZIP_ID1 - GZIP_ID2 - - GZIP_FLG_DEFAULT - GZIP_FLG_FTEXT - GZIP_FLG_FHCRC - GZIP_FLG_FEXTRA - GZIP_FLG_FNAME - GZIP_FLG_FCOMMENT - GZIP_FLG_RESERVED - - GZIP_CM_DEFLATED - - GZIP_MIN_HEADER_SIZE - GZIP_TRAILER_SIZE - - GZIP_MTIME_DEFAULT - GZIP_XFL_DEFAULT - GZIP_FEXTRA_HEADER_SIZE - GZIP_FEXTRA_MAX_SIZE - GZIP_FEXTRA_SUBFIELD_HEADER_SIZE - GZIP_FEXTRA_SUBFIELD_ID_SIZE - GZIP_FEXTRA_SUBFIELD_LEN_SIZE - GZIP_FEXTRA_SUBFIELD_MAX_SIZE - - $GZIP_FNAME_INVALID_CHAR_RE - $GZIP_FCOMMENT_INVALID_CHAR_RE - - GZIP_FHCRC_SIZE - - GZIP_ISIZE_MAX - GZIP_ISIZE_MOD_VALUE - - - GZIP_NULL_BYTE - - GZIP_OS_DEFAULT - - %GZIP_OS_Names - - GZIP_MINIMUM_HEADER - - ); - -# Constant names derived from RFC 1952 - -use constant GZIP_ID_SIZE => 2 ; -use constant GZIP_ID1 => 0x1F; -use constant GZIP_ID2 => 0x8B; - -use constant GZIP_MIN_HEADER_SIZE => 10 ;# minimum gzip header size -use constant GZIP_TRAILER_SIZE => 8 ; - - -use constant GZIP_FLG_DEFAULT => 0x00 ; -use constant GZIP_FLG_FTEXT => 0x01 ; -use constant GZIP_FLG_FHCRC => 0x02 ; # called CONTINUATION in gzip -use constant GZIP_FLG_FEXTRA => 0x04 ; -use constant GZIP_FLG_FNAME => 0x08 ; -use constant GZIP_FLG_FCOMMENT => 0x10 ; -#use constant GZIP_FLG_ENCRYPTED => 0x20 ; # documented in gzip sources -use constant GZIP_FLG_RESERVED => (0x20 | 0x40 | 0x80) ; - -use constant GZIP_XFL_DEFAULT => 0x00 ; - -use constant GZIP_MTIME_DEFAULT => 0x00 ; - -use constant GZIP_FEXTRA_HEADER_SIZE => 2 ; -use constant GZIP_FEXTRA_MAX_SIZE => 0xFFFF ; -use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ; -use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ; -use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => GZIP_FEXTRA_SUBFIELD_ID_SIZE + - GZIP_FEXTRA_SUBFIELD_LEN_SIZE; -use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => GZIP_FEXTRA_MAX_SIZE - - GZIP_FEXTRA_SUBFIELD_HEADER_SIZE ; - - -if (ord('A') == 193) -{ - # EBCDIC - $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x3f\xff]'; - $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x0a\x11-\x14\x16-\x3f\xff]'; - -} -else -{ - $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x1F\x7F-\x9F]'; - $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x09\x11-\x1F\x7F-\x9F]'; -} - -use constant GZIP_FHCRC_SIZE => 2 ; # aka CONTINUATION in gzip - -use constant GZIP_CM_DEFLATED => 8 ; - -use constant GZIP_NULL_BYTE => "\x00"; -use constant GZIP_ISIZE_MAX => 0xFFFFFFFF ; -use constant GZIP_ISIZE_MOD_VALUE => GZIP_ISIZE_MAX + 1 ; - -# OS Names sourced from http://www.gzip.org/format.txt - -use constant GZIP_OS_DEFAULT=> 0xFF ; -%GZIP_OS_Names = ( - 0 => 'MS-DOS', - 1 => 'Amiga', - 2 => 'VMS', - 3 => 'Unix', - 4 => 'VM/CMS', - 5 => 'Atari TOS', - 6 => 'HPFS (OS/2, NT)', - 7 => 'Macintosh', - 8 => 'Z-System', - 9 => 'CP/M', - 10 => 'TOPS-20', - 11 => 'NTFS (NT)', - 12 => 'SMS QDOS', - 13 => 'Acorn RISCOS', - 14 => 'VFAT file system (Win95, NT)', - 15 => 'MVS', - 16 => 'BeOS', - 17 => 'Tandem/NSK', - 18 => 'THEOS', - GZIP_OS_DEFAULT() => 'Unknown', - ) ; - -use constant GZIP_MINIMUM_HEADER => pack("C4 V C C", - GZIP_ID1, GZIP_ID2, GZIP_CM_DEFLATED, GZIP_FLG_DEFAULT, - GZIP_MTIME_DEFAULT, GZIP_XFL_DEFAULT, GZIP_OS_DEFAULT) ; - - -1; diff --git a/ext/IO-Compress/lib/IO/Compress/RawDeflate.pm b/ext/IO-Compress/lib/IO/Compress/RawDeflate.pm deleted file mode 100644 index ad642dbfa5..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/RawDeflate.pm +++ /dev/null @@ -1,976 +0,0 @@ -package IO::Compress::RawDeflate ; - -# create RFC1951 -# -use strict ; -use warnings; -use bytes; - - -use IO::Compress::Base 2.021 ; -use IO::Compress::Base::Common 2.021 qw(:Status createSelfTiedObject); -use IO::Compress::Adapter::Deflate 2.021 ; - -require Exporter ; - - -our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError); - -$VERSION = '2.021'; -$RawDeflateError = ''; - -@ISA = qw(Exporter IO::Compress::Base); -@EXPORT_OK = qw( $RawDeflateError rawdeflate ) ; - -%EXPORT_TAGS = ( flush => [qw{ - Z_NO_FLUSH - Z_PARTIAL_FLUSH - Z_SYNC_FLUSH - Z_FULL_FLUSH - Z_FINISH - Z_BLOCK - }], - level => [qw{ - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - }], - strategy => [qw{ - Z_FILTERED - Z_HUFFMAN_ONLY - Z_RLE - Z_FIXED - Z_DEFAULT_STRATEGY - }], - - ); - -{ - my %seen; - foreach (keys %EXPORT_TAGS ) - { - push @{$EXPORT_TAGS{constants}}, - grep { !$seen{$_}++ } - @{ $EXPORT_TAGS{$_} } - } - $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ; -} - - -%DEFLATE_CONSTANTS = %EXPORT_TAGS; - -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; - -Exporter::export_ok_tags('all'); - - - -sub new -{ - my $class = shift ; - - my $obj = createSelfTiedObject($class, \$RawDeflateError); - - return $obj->_create(undef, @_); -} - -sub rawdeflate -{ - my $obj = createSelfTiedObject(undef, \$RawDeflateError); - return $obj->_def(@_); -} - -sub ckParams -{ - my $self = shift ; - my $got = shift; - - return 1 ; -} - -sub mkComp -{ - my $self = shift ; - my $got = shift ; - - my ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject( - $got->value('CRC32'), - $got->value('Adler32'), - $got->value('Level'), - $got->value('Strategy') - ); - - return $self->saveErrorString(undef, $errstr, $errno) - if ! defined $obj; - - return $obj; -} - - -sub mkHeader -{ - my $self = shift ; - return ''; -} - -sub mkTrailer -{ - my $self = shift ; - return ''; -} - -sub mkFinalTrailer -{ - return ''; -} - - -#sub newHeader -#{ -# my $self = shift ; -# return ''; -#} - -sub getExtraParams -{ - my $self = shift ; - return $self->getZlibParams(); -} - -sub getZlibParams -{ - my $self = shift ; - - use IO::Compress::Base::Common 2.021 qw(:Parse); - use Compress::Raw::Zlib 2.021 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); - - - return ( - - # zlib behaviour - #'Method' => [0, 1, Parse_unsigned, Z_DEFLATED], - 'Level' => [0, 1, Parse_signed, Z_DEFAULT_COMPRESSION], - 'Strategy' => [0, 1, Parse_signed, Z_DEFAULT_STRATEGY], - - 'CRC32' => [0, 1, Parse_boolean, 0], - 'ADLER32' => [0, 1, Parse_boolean, 0], - 'Merge' => [1, 1, Parse_boolean, 0], - ); - - -} - -sub getInverseClass -{ - return ('IO::Uncompress::RawInflate', - \$IO::Uncompress::RawInflate::RawInflateError); -} - -sub getFileInfo -{ - my $self = shift ; - my $params = shift; - my $file = shift ; - -} - -use IO::Seekable qw(SEEK_SET); - -sub createMerge -{ - my $self = shift ; - my $outValue = shift ; - my $outType = shift ; - - my ($invClass, $error_ref) = $self->getInverseClass(); - eval "require $invClass" - or die "aaaahhhh" ; - - my $inf = $invClass->new( $outValue, - Transparent => 0, - #Strict => 1, - AutoClose => 0, - Scan => 1) - or return $self->saveErrorString(undef, "Cannot create InflateScan object: $$error_ref" ) ; - - my $end_offset = 0; - $inf->scan() - or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $inf->errorNo) ; - $inf->zap($end_offset) - or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $inf->errorNo) ; - - my $def = *$self->{Compress} = $inf->createDeflate(); - - *$self->{Header} = *$inf->{Info}{Header}; - *$self->{UnCompSize} = *$inf->{UnCompSize}->clone(); - *$self->{CompSize} = *$inf->{CompSize}->clone(); - # TODO -- fix this - #*$self->{CompSize} = new U64(0, *$self->{UnCompSize_32bit}); - - - if ( $outType eq 'buffer') - { substr( ${ *$self->{Buffer} }, $end_offset) = '' } - elsif ($outType eq 'handle' || $outType eq 'filename') { - *$self->{FH} = *$inf->{FH} ; - delete *$inf->{FH}; - *$self->{FH}->flush() ; - *$self->{Handle} = 1 if $outType eq 'handle'; - - #seek(*$self->{FH}, $end_offset, SEEK_SET) - *$self->{FH}->seek($end_offset, SEEK_SET) - or return $self->saveErrorString(undef, $!, $!) ; - } - - return $def ; -} - -#### zlib specific methods - -sub deflateParams -{ - my $self = shift ; - - my $level = shift ; - my $strategy = shift ; - - my $status = *$self->{Compress}->deflateParams(Level => $level, Strategy => $strategy) ; - return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) - if $status == STATUS_ERROR; - - return 1; -} - - - - -1; - -__END__ - -=head1 NAME - -IO::Compress::RawDeflate - Write RFC 1951 files/buffers - - - -=head1 SYNOPSIS - - use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; - - my $status = rawdeflate $input => $output [,OPTS] - or die "rawdeflate failed: $RawDeflateError\n"; - - my $z = new IO::Compress::RawDeflate $output [,OPTS] - or die "rawdeflate failed: $RawDeflateError\n"; - - $z->print($string); - $z->printf($format, $string); - $z->write($string); - $z->syswrite($string [, $length, $offset]); - $z->flush(); - $z->tell(); - $z->eof(); - $z->seek($position, $whence); - $z->binmode(); - $z->fileno(); - $z->opened(); - $z->autoflush(); - $z->input_line_number(); - $z->newStream( [OPTS] ); - - $z->deflateParams(); - - $z->close() ; - - $RawDeflateError ; - - # 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 - -This module provides a Perl interface that allows writing compressed -data to files or buffer as defined in RFC 1951. - -Note that RFC 1951 data is not a good choice of compression format -to use in isolation, especially if you want to auto-detect it. - -For reading RFC 1951 files/buffers, see the companion module -L<IO::Uncompress::RawInflate|IO::Uncompress::RawInflate>. - -=head1 Functional Interface - -A top-level function, C<rawdeflate>, is provided to carry out -"one-shot" compression between buffers and/or files. For finer -control over the compression process, see the L</"OO Interface"> -section. - - use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; - - rawdeflate $input => $output [,OPTS] - or die "rawdeflate failed: $RawDeflateError\n"; - -The functional interface needs Perl5.005 or better. - -=head2 rawdeflate $input => $output [, OPTS] - -C<rawdeflate> expects at least two parameters, C<$input> and C<$output>. - -=head3 The C<$input> parameter - -The parameter, C<$input>, is used to define the source of -the uncompressed data. - -It can take one of the following forms: - -=over 5 - -=item A filename - -If the C<$input> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for reading and the input data -will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the input data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the input data will be read -from C<$$input>. - -=item An array reference - -If C<$input> is an array reference, 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<rawdeflate> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -compressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the compressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the compressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the compressed data will be -stored in C<$$output>. - -=item An Array Reference - -If C<$output> is an array reference, the compressed data will be -pushed onto the array. - -=item An Output FileGlob - -If C<$output> is a string that is delimited by the characters "<" and ">" -C<rawdeflate> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the input files/buffers will be stored -in C<$output> as a concatenated series of compressed data streams. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<rawdeflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<rawdeflate> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<rawdeflate> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeIn => 0|1 >> - -When reading from a file or filehandle, set C<binmode> before reading. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt> and write the compressed -data to the file C<file1.txt.1951>. - - use strict ; - use warnings ; - use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; - - my $input = "file1.txt"; - rawdeflate $input => "$input.1951" - or die "rawdeflate failed: $RawDeflateError\n"; - -To read from an existing Perl filehandle, C<$input>, and write the -compressed data to a buffer, C<$buffer>. - - use strict ; - use warnings ; - use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; - use IO::File ; - - my $input = new IO::File "<file1.txt" - or die "Cannot open 'file1.txt': $!\n" ; - my $buffer ; - rawdeflate $input => \$buffer - or die "rawdeflate failed: $RawDeflateError\n"; - -To compress all files in the directory "/my/home" that match "*.txt" -and store the compressed data in the same directory - - use strict ; - use warnings ; - use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; - - rawdeflate '</my/home/*.txt>' => '<*.1951>' - or die "rawdeflate failed: $RawDeflateError\n"; - -and if you want to compress each file one at a time, this will do the trick - - use strict ; - use warnings ; - use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; - - for my $input ( glob "/my/home/*.txt" ) - { - my $output = "$input.1951" ; - rawdeflate $input => $output - or die "Error compressing '$input': $RawDeflateError\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for C<IO::Compress::RawDeflate> is shown below - - my $z = new IO::Compress::RawDeflate $output [,OPTS] - or die "IO::Compress::RawDeflate failed: $RawDeflateError\n"; - -It returns an C<IO::Compress::RawDeflate> object on success and undef on failure. -The variable C<$RawDeflateError> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Compress::RawDeflate can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal output file operations can be carried out -with C<$z>. -For example, to write to a compressed file/buffer you can use either of -these forms - - $z->print("hello world\n"); - print $z "hello world\n"; - -The mandatory parameter C<$output> is used to control the destination -of the compressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the compressed data -will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the compressed data will be -written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the compressed data will be stored -in C<$$output>. - -=back - -If the C<$output> parameter is any other type, C<IO::Compress::RawDeflate>::new will -return undef. - -=head2 Constructor Options - -C<OPTS> is any combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$output> parameter is a filehandle. If -specified, and the value is true, it will result in the C<$output> being -closed once either the C<close> method is called or the C<IO::Compress::RawDeflate> -object is destroyed. - -This parameter defaults to 0. - -=item C<< Append => 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<Append> is enabled, all compressed data -will be append to the end if C<$output>. Otherwise C<$output> will be -cleared before any data is written to it. - -=item * A Filename - -If C<$output> is a filename and C<Append> is enabled, the file will be -opened in append mode. Otherwise the contents of the file, if any, will be -truncated before any compressed data is written to it. - -=item * A Filehandle - -If C<$output> is a filehandle, the file pointer will be positioned to the -end of the file via a call to C<seek> before any compressed data is written -to it. Otherwise the file pointer will not be moved. - -=back - -This parameter defaults to 0. - -=item C<< Merge => 0|1 >> - -This option is used to compress input data and append it to an existing -compressed data stream in C<$output>. The end result is a single compressed -data stream stored in C<$output>. - -It is a fatal error to attempt to use this option when C<$output> is not an -RFC 1951 data stream. - -There are a number of other limitations with the C<Merge> option: - -=over 5 - -=item 1 - -This module needs to have been built with zlib 1.2.1 or better to work. A -fatal error will be thrown if C<Merge> is used with an older version of -zlib. - -=item 2 - -If C<$output> is a file or a filehandle, it must be seekable. - -=back - -This parameter defaults to 0. - -=item -Level - -Defines the compression level used by zlib. The value should either be -a number between 0 and 9 (0 means no compression and 9 is maximum -compression), or one of the symbolic constants defined below. - - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - -The default is Z_DEFAULT_COMPRESSION. - -Note, these constants are not imported by C<IO::Compress::RawDeflate> by default. - - use IO::Compress::RawDeflate qw(:strategy); - use IO::Compress::RawDeflate qw(:constants); - use IO::Compress::RawDeflate qw(:all); - -=item -Strategy - -Defines the strategy used to tune the compression. Use one of the symbolic -constants defined below. - - Z_FILTERED - Z_HUFFMAN_ONLY - Z_RLE - Z_FIXED - Z_DEFAULT_STRATEGY - -The default is Z_DEFAULT_STRATEGY. - -=item C<< Strict => 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<print> built-in. - -Returns true if successful. - -=head2 printf - -Usage is - - $z->printf($format, $data) - printf $z $format, $data - -Compresses and outputs the contents of the C<$data> parameter. - -Returns true if successful. - -=head2 syswrite - -Usage is - - $z->syswrite $data - $z->syswrite $data, $length - $z->syswrite $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 write - -Usage is - - $z->write $data - $z->write $data, $length - $z->write $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 flush - -Usage is - - $z->flush; - $z->flush($flush_type); - -Flushes any pending compressed data to the output file/buffer. - -This method takes an optional parameter, C<$flush_type>, that controls -how the flushing will be carried out. By default the C<$flush_type> -used is C<Z_FINISH>. Other valid values for C<$flush_type> are -C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is -strongly recommended that you only set the C<flush_type> parameter if -you fully understand the implications of what it does - overuse of C<flush> -can seriously degrade the level of compression achieved. See the C<zlib> -documentation for details. - -Returns true on success. - -=head2 tell - -Usage is - - $z->tell() - tell $z - -Returns the uncompressed file offset. - -=head2 eof - -Usage is - - $z->eof(); - eof($z); - -Returns true if the C<close> method has been called. - -=head2 seek - - $z->seek($position, $whence); - seek($z, $position, $whence); - -Provides a sub-set of the C<seek> functionality, with the restriction -that it is only legal to seek forward in the output file/buffer. -It is a fatal error to attempt to seek backward. - -Empty parts of the file/buffer will have NULL (0x00) bytes written to them. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<undef> when compressing. - -=head2 fileno - - $z->fileno() - fileno($z) - -If the C<$z> object is associated with a file or a filehandle, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<undef>. - -=head2 close - - $z->close() ; - close $z ; - -Flushes any pending compressed data and then closes the output file/buffer. - -For most versions of Perl this method will be automatically invoked if -the IO::Compress::RawDeflate object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Compress::RawDeflate -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 newStream([OPTS]) - -Usage is - - $z->newStream( [OPTS] ) - -Closes the current compressed data stream and starts a new one. - -OPTS consists of any of the the options that are available when creating -the C<$z> object. - -See the L</"Constructor Options"> section for more details. - -=head2 deflateParams - -Usage is - - $z->deflateParams - -TODO - -=head1 Importing - -A number of symbolic constants are required by some methods in -C<IO::Compress::RawDeflate>. None are imported by default. - -=over 5 - -=item :all - -Imports C<rawdeflate>, C<$RawDeflateError> and all symbolic -constants that can be used by C<IO::Compress::RawDeflate>. Same as doing this - - use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError :constants) ; - -=item :constants - -Import all symbolic constants. Same as doing this - - use IO::Compress::RawDeflate qw(:flush :level :strategy) ; - -=item :flush - -These symbolic constants are used by the C<flush> method. - - Z_NO_FLUSH - Z_PARTIAL_FLUSH - Z_SYNC_FLUSH - Z_FULL_FLUSH - Z_FINISH - Z_BLOCK - -=item :level - -These symbolic constants are used by the C<Level> option in the constructor. - - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - -=item :strategy - -These symbolic constants are used by the C<Strategy> option in the constructor. - - Z_FILTERED - Z_HUFFMAN_ONLY - Z_RLE - Z_FIXED - Z_DEFAULT_STRATEGY - - - - -=back - -=head1 EXAMPLES - -=head2 Apache::GZip Revisited - -See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> - - - -=head2 Working with Net::FTP - -See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Compress/Zip.pm b/ext/IO-Compress/lib/IO/Compress/Zip.pm deleted file mode 100644 index 563b10d9bf..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Zip.pm +++ /dev/null @@ -1,1570 +0,0 @@ -package IO::Compress::Zip ; - -use strict ; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(:Status createSelfTiedObject); -use IO::Compress::RawDeflate 2.021 ; -use IO::Compress::Adapter::Deflate 2.021 ; -use IO::Compress::Adapter::Identity 2.021 ; -use IO::Compress::Zlib::Extra 2.021 ; -use IO::Compress::Zip::Constants 2.021 ; - - -use Compress::Raw::Zlib 2.021 qw(crc32) ; -BEGIN -{ - eval { require IO::Compress::Adapter::Bzip2 ; - import IO::Compress::Adapter::Bzip2 2.021 ; - require IO::Compress::Bzip2 ; - import IO::Compress::Bzip2 2.021 ; - } ; - eval { require IO::Compress::Adapter::Lzma ; - import IO::Compress::Adapter::Lzma 2.020 ; - require IO::Compress::Lzma ; - import IO::Compress::Lzma 2.020 ; - } ; -} - - -require Exporter ; - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $ZipError); - -$VERSION = '2.021'; -$ZipError = ''; - -@ISA = qw(Exporter IO::Compress::RawDeflate); -@EXPORT_OK = qw( $ZipError zip ) ; -%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; - -$EXPORT_TAGS{zip_method} = [qw( ZIP_CM_STORE ZIP_CM_DEFLATE ZIP_CM_BZIP2 ZIP_CM_LZMA)]; -push @{ $EXPORT_TAGS{all} }, @{ $EXPORT_TAGS{zip_method} }; - -Exporter::export_ok_tags('all'); - -sub new -{ - my $class = shift ; - - my $obj = createSelfTiedObject($class, \$ZipError); - $obj->_create(undef, @_); -} - -sub zip -{ - my $obj = createSelfTiedObject(undef, \$ZipError); - return $obj->_def(@_); -} - -sub mkComp -{ - my $self = shift ; - my $got = shift ; - - my ($obj, $errstr, $errno) ; - - if (*$self->{ZipData}{Method} == ZIP_CM_STORE) { - ($obj, $errstr, $errno) = IO::Compress::Adapter::Identity::mkCompObject( - $got->value('Level'), - $got->value('Strategy') - ); - *$self->{ZipData}{CRC32} = crc32(undef); - } - elsif (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { - ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject( - $got->value('CRC32'), - $got->value('Adler32'), - $got->value('Level'), - $got->value('Strategy') - ); - } - elsif (*$self->{ZipData}{Method} == ZIP_CM_BZIP2) { - ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject( - $got->value('BlockSize100K'), - $got->value('WorkFactor'), - $got->value('Verbosity') - ); - *$self->{ZipData}{CRC32} = crc32(undef); - } - elsif (*$self->{ZipData}{Method} == ZIP_CM_LZMA) { - ($obj, $errstr, $errno) = IO::Compress::Adapter::Lzma::mkCompObject(); - *$self->{ZipData}{CRC32} = crc32(undef); - } - - return $self->saveErrorString(undef, $errstr, $errno) - if ! defined $obj; - - if (! defined *$self->{ZipData}{SizesOffset}) { - *$self->{ZipData}{SizesOffset} = 0; - *$self->{ZipData}{Offset} = new U64 ; - } - - *$self->{ZipData}{AnyZip64} = 0 - if ! defined *$self->{ZipData}{AnyZip64} ; - - return $obj; -} - -sub reset -{ - my $self = shift ; - - *$self->{Compress}->reset(); - *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(''); - - return STATUS_OK; -} - -sub filterUncompressed -{ - my $self = shift ; - - if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { - *$self->{ZipData}{CRC32} = *$self->{Compress}->crc32(); - } - else { - *$self->{ZipData}{CRC32} = crc32(${$_[0]}, *$self->{ZipData}{CRC32}); - - } -} - -sub mkHeader -{ - my $self = shift; - my $param = shift ; - - - *$self->{ZipData}{LocalHdrOffset} = U64::clone(*$self->{ZipData}{Offset}); - - my $filename = ''; - $filename = $param->value('Name') || ''; - - my $comment = ''; - $comment = $param->value('Comment') || ''; - - my $hdr = ''; - - my $time = _unixToDosTime($param->value('Time')); - - my $extra = ''; - my $ctlExtra = ''; - my $empty = 0; - my $osCode = $param->value('OS_Code') ; - my $extFileAttr = 0 ; - - # This code assumes Unix. - $extFileAttr = 0666 << 16 - if $osCode == ZIP_OS_CODE_UNIX ; - - if (*$self->{ZipData}{Zip64}) { - $empty = 0xFFFFFFFF; - - my $x = ''; - $x .= pack "V V", 0, 0 ; # uncompressedLength - $x .= pack "V V", 0, 0 ; # compressedLength - $extra .= IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x); - } - - if (! $param->value('Minimal')) { - if (defined $param->value('exTime')) - { - $extra .= mkExtendedTime($param->value('MTime'), - $param->value('ATime'), - $param->value('CTime')); - - $ctlExtra .= mkExtendedTime($param->value('MTime')); - } - - if ( $param->value('UID') && $osCode == ZIP_OS_CODE_UNIX) - { - $extra .= mkUnix2Extra( $param->value('UID'), $param->value('GID')); - $ctlExtra .= mkUnix2Extra(); - } - - $extFileAttr = $param->value('ExtAttr') - if defined $param->value('ExtAttr') ; - - $extra .= $param->value('ExtraFieldLocal') - if defined $param->value('ExtraFieldLocal'); - - $ctlExtra .= $param->value('ExtraFieldCentral') - if defined $param->value('ExtraFieldCentral'); - } - - my $gpFlag = 0 ; - $gpFlag |= ZIP_GP_FLAG_STREAMING_MASK - if *$self->{ZipData}{Stream} ; - - my $method = *$self->{ZipData}{Method} ; - - my $version = $ZIP_CM_MIN_VERSIONS{$method}; - $version = ZIP64_MIN_VERSION - if ZIP64_MIN_VERSION > $version && *$self->{ZipData}{Zip64}; - my $madeBy = ($param->value('OS_Code') << 8) + $version; - my $extract = $version; - - *$self->{ZipData}{Version} = $version; - *$self->{ZipData}{MadeBy} = $madeBy; - - my $ifa = 0; - $ifa |= ZIP_IFA_TEXT_MASK - if $param->value('TextFlag'); - - $hdr .= pack "V", ZIP_LOCAL_HDR_SIG ; # signature - $hdr .= pack 'v', $extract ; # extract Version & OS - $hdr .= pack 'v', $gpFlag ; # general purpose flag (set streaming mode) - $hdr .= pack 'v', $method ; # compression method (deflate) - $hdr .= pack 'V', $time ; # last mod date/time - $hdr .= pack 'V', 0 ; # crc32 - 0 when streaming - $hdr .= pack 'V', $empty ; # compressed length - 0 when streaming - $hdr .= pack 'V', $empty ; # uncompressed length - 0 when streaming - $hdr .= pack 'v', length $filename ; # filename length - $hdr .= pack 'v', length $extra ; # extra length - - $hdr .= $filename ; - - # Remember the offset for the compressed & uncompressed lengths in the - # local header. - if (*$self->{ZipData}{Zip64}) { - *$self->{ZipData}{SizesOffset} = *$self->{ZipData}{Offset}->get64bit() - + length($hdr) + 4 ; - } - else { - *$self->{ZipData}{SizesOffset} = *$self->{ZipData}{Offset}->get64bit() - + 18; - } - - $hdr .= $extra ; - - - my $ctl = ''; - - $ctl .= pack "V", ZIP_CENTRAL_HDR_SIG ; # signature - $ctl .= pack 'v', $madeBy ; # version made by - $ctl .= pack 'v', $extract ; # extract Version - $ctl .= pack 'v', $gpFlag ; # general purpose flag (streaming mode) - $ctl .= pack 'v', $method ; # compression method (deflate) - $ctl .= pack 'V', $time ; # last mod date/time - $ctl .= pack 'V', 0 ; # crc32 - $ctl .= pack 'V', $empty ; # compressed length - $ctl .= pack 'V', $empty ; # uncompressed length - $ctl .= pack 'v', length $filename ; # filename length - - *$self->{ZipData}{ExtraOffset} = length $ctl; - *$self->{ZipData}{ExtraSize} = length $ctlExtra ; - - $ctl .= pack 'v', length $ctlExtra ; # extra length - $ctl .= pack 'v', length $comment ; # file comment length - $ctl .= pack 'v', 0 ; # disk number start - $ctl .= pack 'v', $ifa ; # internal file attributes - $ctl .= pack 'V', $extFileAttr ; # external file attributes - - # offset to local hdr - if (*$self->{ZipData}{LocalHdrOffset}->is64bit() ) { - $ctl .= pack 'V', 0xFFFFFFFF ; - } - else { - $ctl .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V32() ; - } - - $ctl .= $filename ; - $ctl .= $ctlExtra ; - $ctl .= $comment ; - - *$self->{ZipData}{Offset}->add(length $hdr) ; - - *$self->{ZipData}{CentralHeader} = $ctl; - - return $hdr; -} - -sub mkTrailer -{ - my $self = shift ; - - my $crc32 ; - if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { - $crc32 = pack "V", *$self->{Compress}->crc32(); - } - else { - $crc32 = pack "V", *$self->{ZipData}{CRC32}; - } - - my $ctl = *$self->{ZipData}{CentralHeader} ; - - my $sizes ; - if (! *$self->{ZipData}{Zip64}) { - $sizes .= *$self->{CompSize}->getPacked_V32() ; # Compressed size - $sizes .= *$self->{UnCompSize}->getPacked_V32() ; # Uncompressed size - } - else { - $sizes .= *$self->{CompSize}->getPacked_V64() ; # Compressed size - $sizes .= *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size - } - - my $data = $crc32 . $sizes ; - - my $xtrasize = *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size - $xtrasize .= *$self->{CompSize}->getPacked_V64() ; # Compressed size - - my $hdr = ''; - - if (*$self->{ZipData}{Stream}) { - $hdr = pack "V", ZIP_DATA_HDR_SIG ; # signature - $hdr .= $data ; - } - else { - $self->writeAt(*$self->{ZipData}{LocalHdrOffset}->get64bit() + 14, $crc32) - or return undef; - $self->writeAt(*$self->{ZipData}{SizesOffset}, - *$self->{ZipData}{Zip64} ? $xtrasize : $sizes) - or return undef; - } - - # Central Header Record/Zip64 extended field - - substr($ctl, 16, length $crc32) = $crc32 ; - - my $x = ''; - - # uncompressed length - if (*$self->{UnCompSize}->is64bit() ) { - $x .= *$self->{UnCompSize}->getPacked_V64() ; - } else { - substr($ctl, 24, 4) = *$self->{UnCompSize}->getPacked_V32() ; - } - - # compressed length - if (*$self->{CompSize}->is64bit() ) { - $x .= *$self->{CompSize}->getPacked_V64() ; - } else { - substr($ctl, 20, 4) = *$self->{CompSize}->getPacked_V32() ; - } - - # Local Header offset - $x .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V64() - if *$self->{ZipData}{LocalHdrOffset}->is64bit() ; - - # disk no - always zero, so don't need it - #$x .= pack "V", 0 ; - - if (length $x) { - my $xtra = IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x); - $ctl .= $xtra ; - substr($ctl, *$self->{ZipData}{ExtraOffset}, 2) = - pack 'v', *$self->{ZipData}{ExtraSize} + length $xtra; - - *$self->{ZipData}{AnyZip64} = 1; - } - - *$self->{ZipData}{Offset}->add(length($hdr)); - *$self->{ZipData}{Offset}->add( *$self->{CompSize} ); - push @{ *$self->{ZipData}{CentralDir} }, $ctl ; - - return $hdr; -} - -sub mkFinalTrailer -{ - my $self = shift ; - - my $comment = ''; - $comment = *$self->{ZipData}{ZipComment} ; - - my $cd_offset = *$self->{ZipData}{Offset}->get32bit() ; # offset to start central dir - - my $entries = @{ *$self->{ZipData}{CentralDir} }; - my $cd = join '', @{ *$self->{ZipData}{CentralDir} }; - my $cd_len = length $cd ; - - my $z64e = ''; - - if ( *$self->{ZipData}{AnyZip64} ) { - - my $v = *$self->{ZipData}{Version} ; - my $mb = *$self->{ZipData}{MadeBy} ; - $z64e .= pack 'v', $mb ; # Version made by - $z64e .= pack 'v', $v ; # Version to extract - $z64e .= pack 'V', 0 ; # number of disk - $z64e .= pack 'V', 0 ; # number of disk with central dir - $z64e .= U64::pack_V64 $entries ; # entries in central dir on this disk - $z64e .= U64::pack_V64 $entries ; # entries in central dir - $z64e .= U64::pack_V64 $cd_len ; # size of central dir - $z64e .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to start central dir - - $z64e = pack("V", ZIP64_END_CENTRAL_REC_HDR_SIG) # signature - . U64::pack_V64(length $z64e) - . $z64e ; - - *$self->{ZipData}{Offset}->add(length $cd) ; - - $z64e .= pack "V", ZIP64_END_CENTRAL_LOC_HDR_SIG; # signature - $z64e .= pack 'V', 0 ; # number of disk with central dir - $z64e .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to end zip64 central dir - $z64e .= pack 'V', 1 ; # Total number of disks - - $cd_offset = 0xFFFFFFFF ; - $cd_len = 0xFFFFFFFF if $cd_len >= 0xFFFFFFFF ; - $entries = 0xFFFF if $entries >= 0xFFFF ; - } - - my $ecd = ''; - $ecd .= pack "V", ZIP_END_CENTRAL_HDR_SIG ; # signature - $ecd .= pack 'v', 0 ; # number of disk - $ecd .= pack 'v', 0 ; # number of disk with central dir - $ecd .= pack 'v', $entries ; # entries in central dir on this disk - $ecd .= pack 'v', $entries ; # entries in central dir - $ecd .= pack 'V', $cd_len ; # size of central dir - $ecd .= pack 'V', $cd_offset ; # offset to start central dir - $ecd .= pack 'v', length $comment ; # zipfile comment length - $ecd .= $comment; - - return $cd . $z64e . $ecd ; -} - -sub ckParams -{ - my $self = shift ; - my $got = shift; - - $got->value('CRC32' => 1); - - if (! $got->parsed('Time') ) { - # Modification time defaults to now. - $got->value('Time' => time) ; - } - - if ($got->parsed('exTime') ) { - my $timeRef = $got->value('exTime'); - if ( defined $timeRef) { - return $self->saveErrorString(undef, "exTime not a 3-element array ref") - if ref $timeRef ne 'ARRAY' || @$timeRef != 3; - } - - $got->value("MTime", $timeRef->[1]); - $got->value("ATime", $timeRef->[0]); - $got->value("CTime", $timeRef->[2]); - } - - # Unix2 Extended Attribute - if ($got->parsed('exUnix2') ) { - my $timeRef = $got->value('exUnix2'); - if ( defined $timeRef) { - return $self->saveErrorString(undef, "exUnix2 not a 2-element array ref") - if ref $timeRef ne 'ARRAY' || @$timeRef != 2; - } - - $got->value("UID", $timeRef->[0]); - $got->value("GID", $timeRef->[1]); - } - - *$self->{ZipData}{AnyZip64} = 1 - if $got->value('Zip64'); - *$self->{ZipData}{Zip64} = $got->value('Zip64'); - *$self->{ZipData}{Stream} = $got->value('Stream'); - - my $method = $got->value('Method'); - return $self->saveErrorString(undef, "Unknown Method '$method'") - if ! defined $ZIP_CM_MIN_VERSIONS{$method}; - - return $self->saveErrorString(undef, "Bzip2 not available") - if $method == ZIP_CM_BZIP2 and - ! defined $IO::Compress::Adapter::Bzip2::VERSION; - - return $self->saveErrorString(undef, "Lzma not available") - if $method == ZIP_CM_LZMA and - ! defined $IO::Compress::Adapter::Lzma::VERSION; - - *$self->{ZipData}{Method} = $method; - - *$self->{ZipData}{ZipComment} = $got->value('ZipComment') ; - - for my $name (qw( ExtraFieldLocal ExtraFieldCentral )) - { - my $data = $got->value($name) ; - if (defined $data) { - my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, 1, 0) ; - return $self->saveErrorString(undef, "Error with $name Parameter: $bad") - if $bad ; - - $got->value($name, $data) ; - } - } - - return undef - if defined $IO::Compress::Bzip2::VERSION - and ! IO::Compress::Bzip2::ckParams($self, $got); - - return 1 ; -} - -#sub newHeader -#{ -# my $self = shift ; -# -# return $self->mkHeader(*$self->{Got}); -#} - -sub getExtraParams -{ - my $self = shift ; - - use IO::Compress::Base::Common 2.021 qw(:Parse); - use Compress::Raw::Zlib 2.021 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); - - my @Bzip2 = (); - - @Bzip2 = IO::Compress::Bzip2::getExtraParams($self) - if defined $IO::Compress::Bzip2::VERSION; - - return ( - # zlib behaviour - $self->getZlibParams(), - - 'Stream' => [1, 1, Parse_boolean, 1], - #'Store' => [0, 1, Parse_boolean, 0], - 'Method' => [0, 1, Parse_unsigned, ZIP_CM_DEFLATE], - -# # Zip header fields - 'Minimal' => [0, 1, Parse_boolean, 0], - 'Zip64' => [0, 1, Parse_boolean, 0], - 'Comment' => [0, 1, Parse_any, ''], - 'ZipComment'=> [0, 1, Parse_any, ''], - 'Name' => [0, 1, Parse_any, ''], - 'Time' => [0, 1, Parse_any, undef], - 'exTime' => [0, 1, Parse_any, undef], - 'exUnix2' => [0, 1, Parse_any, undef], - 'ExtAttr' => [0, 1, Parse_any, 0], - 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code], - - 'TextFlag' => [0, 1, Parse_boolean, 0], - 'ExtraFieldLocal' => [0, 1, Parse_any, undef], - 'ExtraFieldCentral'=> [0, 1, Parse_any, undef], - - @Bzip2, - ); -} - -sub getInverseClass -{ - return ('IO::Uncompress::Unzip', - \$IO::Uncompress::Unzip::UnzipError); -} - -sub getFileInfo -{ - my $self = shift ; - my $params = shift; - my $filename = shift ; - - my ($mode, $uid, $gid, $atime, $mtime, $ctime) - = (stat($filename))[2, 4,5, 8,9,10] ; - - $params->value('Name' => $filename) - if ! $params->parsed('Name') ; - - $params->value('Time' => $mtime) - if ! $params->parsed('Time') ; - - if ( ! $params->parsed('exTime')) - { - $params->value('MTime' => $mtime) ; - $params->value('ATime' => $atime) ; - $params->value('CTime' => undef) ; # No Creation time - $params->value("exTime", [$mtime, $atime, undef]); - } - - # NOTE - Unix specific code alert - $params->value('ExtAttr' => $mode << 16) - if ! $params->parsed('ExtAttr'); - - $params->value('UID' => $uid) ; - $params->value('GID' => $gid) ; - -} - -sub mkExtendedTime -{ - # order expected is m, a, c - - my $times = ''; - my $bit = 1 ; - my $flags = 0; - - for my $time (@_) - { - if (defined $time) - { - $flags |= $bit; - $times .= pack("V", $time); - } - - $bit <<= 1 ; - } - - return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_EXT_TIMESTAMP, - pack("C", $flags) . $times); -} - -sub mkUnix2Extra -{ - my $ids = ''; - for my $id (@_) - { - $ids .= pack("v", $id); - } - - return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_INFO_ZIP_UNIX2, - $ids); -} - - -# from Archive::Zip -sub _unixToDosTime # Archive::Zip::Member -{ - my $time_t = shift; - # TODO - add something to cope with unix time < 1980 - my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t); - my $dt = 0; - $dt += ( $sec >> 1 ); - $dt += ( $min << 5 ); - $dt += ( $hour << 11 ); - $dt += ( $mday << 16 ); - $dt += ( ( $mon + 1 ) << 21 ); - $dt += ( ( $year - 80 ) << 25 ); - return $dt; -} - -1; - -__END__ - -=head1 NAME - -IO::Compress::Zip - Write zip files/buffers - - - -=head1 SYNOPSIS - - use IO::Compress::Zip qw(zip $ZipError) ; - - my $status = zip $input => $output [,OPTS] - or die "zip failed: $ZipError\n"; - - my $z = new IO::Compress::Zip $output [,OPTS] - or die "zip failed: $ZipError\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() ; - - $ZipError ; - - # 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 - -This module provides a Perl interface that allows writing zip -compressed data to files or buffer. - -The primary purpose of this module is to provide streaming write access to -zip files and buffers. It is not a general-purpose file archiver. If that -is what you want, check out C<Archive::Zip>. - -At present three compression methods are supported by IO::Compress::Zip, -namely Store (no compression at all), Deflate and Bzip2. - -Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must -be installed. - -For reading zip files/buffers, see the companion module -L<IO::Uncompress::Unzip|IO::Uncompress::Unzip>. - -=head1 Functional Interface - -A top-level function, C<zip>, is provided to carry out -"one-shot" compression between buffers and/or files. For finer -control over the compression process, see the L</"OO Interface"> -section. - - use IO::Compress::Zip qw(zip $ZipError) ; - - zip $input => $output [,OPTS] - or die "zip failed: $ZipError\n"; - -The functional interface needs Perl5.005 or better. - -=head2 zip $input => $output [, OPTS] - -C<zip> 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<zip> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -In addition, if C<$input> is a simple filename, the default values for -the C<Name>, C<Time>, C<ExtAttr> and C<exTime> options will be sourced from that file. - -If you do not want to use these defaults they can be overridden by -explicitly setting the C<Name>, C<Time>, C<ExtAttr> and C<exTime> options or by setting the -C<Minimal> parameter. - -=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<zip> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple files/buffers and C<$output> is a single -file/buffer the input files/buffers will each be stored -in C<$output> as a distinct entry. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<zip>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<zip> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<zip> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeIn => 0|1 >> - -When reading from a file or filehandle, set C<binmode> before reading. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt> and write the compressed -data to the file C<file1.txt.zip>. - - use strict ; - use warnings ; - use IO::Compress::Zip qw(zip $ZipError) ; - - my $input = "file1.txt"; - zip $input => "$input.zip" - or die "zip failed: $ZipError\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::Zip qw(zip $ZipError) ; - use IO::File ; - - my $input = new IO::File "<file1.txt" - or die "Cannot open 'file1.txt': $!\n" ; - my $buffer ; - zip $input => \$buffer - or die "zip failed: $ZipError\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::Zip qw(zip $ZipError) ; - - zip '</my/home/*.txt>' => '<*.zip>' - or die "zip failed: $ZipError\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::Zip qw(zip $ZipError) ; - - for my $input ( glob "/my/home/*.txt" ) - { - my $output = "$input.zip" ; - zip $input => $output - or die "Error compressing '$input': $ZipError\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for C<IO::Compress::Zip> is shown below - - my $z = new IO::Compress::Zip $output [,OPTS] - or die "IO::Compress::Zip failed: $ZipError\n"; - -It returns an C<IO::Compress::Zip> object on success and undef on failure. -The variable C<$ZipError> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Compress::Zip can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal output file operations can be carried out -with C<$z>. -For example, to write to a compressed file/buffer you can use either of -these forms - - $z->print("hello world\n"); - print $z "hello world\n"; - -The mandatory parameter C<$output> is used to control the destination -of the compressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the compressed data -will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the compressed data will be -written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the compressed data will be stored -in C<$$output>. - -=back - -If the C<$output> parameter is any other type, C<IO::Compress::Zip>::new will -return undef. - -=head2 Constructor Options - -C<OPTS> is any combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$output> parameter is a filehandle. If -specified, and the value is true, it will result in the C<$output> being -closed once either the C<close> method is called or the C<IO::Compress::Zip> -object is destroyed. - -This parameter defaults to 0. - -=item C<< Append => 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<Append> is enabled, all compressed data -will be append to the end if C<$output>. Otherwise C<$output> will be -cleared before any data is written to it. - -=item * A Filename - -If C<$output> is a filename and C<Append> is enabled, the file will be -opened in append mode. Otherwise the contents of the file, if any, will be -truncated before any compressed data is written to it. - -=item * A Filehandle - -If C<$output> is a filehandle, the file pointer will be positioned to the -end of the file via a call to C<seek> before any compressed data is written -to it. Otherwise the file pointer will not be moved. - -=back - -This parameter defaults to 0. - -=item C<< Name => $string >> - -Stores the contents of C<$string> in the zip filename header field. If -C<Name> is not specified, no zip filename field will be created. - -=item C<< Time => $number >> - -Sets the last modified time field in the zip header to $number. - -This field defaults to the time the C<IO::Compress::Zip> object was created -if this option is not specified. - -=item C<< ExtAttr => $attr >> - -This option controls the "external file attributes" field in the central -header of the zip file. This is a 4 byte field. - -If you are running a Unix derivative this value defaults to - - 0666 << 16 - -This should allow read/write access to any files that are extracted from -the zip file/buffer. - -For all other systems it defaults to 0. - -=item C<< exTime => [$atime, $mtime, $ctime] >> - -This option expects an array reference with exactly three elements: -C<$atime>, C<mtime> and C<$ctime>. These correspond to the last access -time, last modification time and creation time respectively. - -It uses these values to set the extended timestamp field (ID is "UT") in -the local zip header using the three values, $atime, $mtime, $ctime. In -addition it sets the extended timestamp field in the central zip header -using C<$mtime>. - -If any of the three values is C<undef> that time value will not be used. -So, for example, to set only the C<$mtime> you would use this - - exTime => [undef, $mtime, undef] - -If the C<Minimal> option is set to true, this option will be ignored. - -By default no extended time field is created. - -=item C<< exUnix2 => [$uid, $gid] >> - -This option expects an array reference with exactly two elements: C<$uid> -and C<$gid>. These values correspond to the numeric user ID and group ID -of the owner of the files respectively. - -When the C<exUnix2> option is present it will trigger the creation of a -Unix2 extra field (ID is "Ux") in the local zip. This will be populated -with C<$uid> and C<$gid>. In addition an empty Unix2 extra field will also -be created in the central zip header - -If the C<Minimal> option is set to true, this option will be ignored. - -By default no Unix2 extra field is created. - -=item C<< Comment => $comment >> - -Stores the contents of C<$comment> in the Central File Header of -the zip file. - -By default, no comment field is written to the zip file. - -=item C<< ZipComment => $comment >> - -Stores the contents of C<$comment> in the End of Central Directory record -of the zip file. - -By default, no comment field is written to the zip file. - -=item C<< Method => $method >> - -Controls which compression method is used. At present three compression -methods are supported, namely Store (no compression at all), Deflate and -Bzip2. - -The symbols, ZIP_CM_STORE, ZIP_CM_DEFLATE and ZIP_CM_BZIP2 are used to -select the compression method. - -These constants are not imported by C<IO::Compress::Zip> by default. - - use IO::Compress::Zip qw(:zip_method); - use IO::Compress::Zip qw(:constants); - use IO::Compress::Zip qw(:all); - -Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must -be installed. A fatal error will be thrown if you attempt to create Bzip2 -content when C<IO::Compress::Bzip2> is not available. - -The default method is ZIP_CM_DEFLATE. - -=item C<< Stream => 0|1 >> - -This option controls whether the zip file/buffer output is created in -streaming mode. - -Note that when outputting to a file with streaming mode disabled (C<Stream> -is 0), the output file must be seekable. - -The default is 1. - -=item C<< Zip64 => 0|1 >> - -Create a Zip64 zip file/buffer. This option should only be used if you want -to store files larger than 4 Gig. - -If you intend to manipulate the Zip64 zip files created with this module -using an external zip/unzip make sure that it supports Zip64. - -In particular, if you are using Info-Zip you need to have zip version 3.x -or better to update a Zip64 archive and unzip version 6.x to read a zip64 -archive. - -The default is 0. - -=item C<< TextFlag => 0|1 >> - -This parameter controls the setting of a bit in the zip central header. It -is used to signal that the data stored in the zip file/buffer is probably -text. - -The default is 0. - -=item C<< ExtraFieldLocal => $data >> -=item C<< ExtraFieldCentral => $data >> - -The C<ExtraFieldLocal> option is used to store additional metadata in the -local header for the zip file/buffer. The C<ExtraFieldCentral> does the -same for the matching central header. - -An extra field consists of zero or more subfields. Each subfield consists -of a two byte header followed by the subfield data. - -The list of subfields can be supplied in any of the following formats - - ExtraFieldLocal => [$id1, $data1, - $id2, $data2, - ... - ] - - ExtraFieldLocal => [ [$id1 => $data1], - [$id2 => $data2], - ... - ] - - ExtraFieldLocal => { $id1 => $data1, - $id2 => $data2, - ... - } - -Where C<$id1>, C<$id2> are two byte subfield ID's. - -If you use the hash syntax, you have no control over the order in which -the ExtraSubFields are stored, plus you cannot have SubFields with -duplicate ID. - -Alternatively the list of subfields can by supplied as a scalar, thus - - ExtraField => $rawdata - -The Extended Time field (ID "UT"), set using the C<exTime> option, and the -Unix2 extra field (ID "Ux), set using the C<exUnix2> option, are examples -of extra fields. - -If the C<Minimal> option is set to true, this option will be ignored. - -The maximum size of an extra field 65535 bytes. - -=item C<< Minimal => 1|0 >> - -If specified, this option will disable the creation of all extra fields -in the zip local and central headers. So the C<exTime>, C<exUnix2>, -C<ExtraFieldLocal> and C<ExtraFieldCentral> options will be ignored. - -This parameter defaults to 0. - -=item C<< BlockSize100K => number >> - -Specify the number of 100K blocks bzip2 uses during compression. - -Valid values are from 1 to 9, where 9 is best compression. - -This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored -otherwise. - -The default is 1. - -=item C<< WorkFactor => number >> - -Specifies how much effort bzip2 should take before resorting to a slower -fallback compression algorithm. - -Valid values range from 0 to 250, where 0 means use the default value 30. - -This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored -otherwise. - -The default is 0. - -=item -Level - -Defines the compression level used by zlib. The value should either be -a number between 0 and 9 (0 means no compression and 9 is maximum -compression), or one of the symbolic constants defined below. - - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - -The default is Z_DEFAULT_COMPRESSION. - -Note, these constants are not imported by C<IO::Compress::Zip> by default. - - use IO::Compress::Zip qw(:strategy); - use IO::Compress::Zip qw(:constants); - use IO::Compress::Zip 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 C<< Strict => 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<print> built-in. - -Returns true if successful. - -=head2 printf - -Usage is - - $z->printf($format, $data) - printf $z $format, $data - -Compresses and outputs the contents of the C<$data> parameter. - -Returns true if successful. - -=head2 syswrite - -Usage is - - $z->syswrite $data - $z->syswrite $data, $length - $z->syswrite $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 write - -Usage is - - $z->write $data - $z->write $data, $length - $z->write $data, $length, $offset - -Compresses and outputs the contents of the C<$data> parameter. - -Returns the number of uncompressed bytes written, or C<undef> if -unsuccessful. - -=head2 flush - -Usage is - - $z->flush; - $z->flush($flush_type); - -Flushes any pending compressed data to the output file/buffer. - -This method takes an optional parameter, C<$flush_type>, that controls -how the flushing will be carried out. By default the C<$flush_type> -used is C<Z_FINISH>. Other valid values for C<$flush_type> are -C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is -strongly recommended that you only set the C<flush_type> parameter if -you fully understand the implications of what it does - overuse of C<flush> -can seriously degrade the level of compression achieved. See the C<zlib> -documentation for details. - -Returns true on success. - -=head2 tell - -Usage is - - $z->tell() - tell $z - -Returns the uncompressed file offset. - -=head2 eof - -Usage is - - $z->eof(); - eof($z); - -Returns true if the C<close> method has been called. - -=head2 seek - - $z->seek($position, $whence); - seek($z, $position, $whence); - -Provides a sub-set of the C<seek> functionality, with the restriction -that it is only legal to seek forward in the output file/buffer. -It is a fatal error to attempt to seek backward. - -Empty parts of the file/buffer will have NULL (0x00) bytes written to them. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<undef> when compressing. - -=head2 fileno - - $z->fileno() - fileno($z) - -If the C<$z> object is associated with a file or a filehandle, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<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::Zip object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Compress::Zip -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 any of the the options that are available when creating -the C<$z> object. - -See the L</"Constructor Options"> section for more details. - -=head2 deflateParams - -Usage is - - $z->deflateParams - -TODO - -=head1 Importing - -A number of symbolic constants are required by some methods in -C<IO::Compress::Zip>. None are imported by default. - -=over 5 - -=item :all - -Imports C<zip>, C<$ZipError> and all symbolic -constants that can be used by C<IO::Compress::Zip>. Same as doing this - - use IO::Compress::Zip qw(zip $ZipError :constants) ; - -=item :constants - -Import all symbolic constants. Same as doing this - - use IO::Compress::Zip qw(:flush :level :strategy :zip_method) ; - -=item :flush - -These symbolic constants are used by the C<flush> method. - - Z_NO_FLUSH - Z_PARTIAL_FLUSH - Z_SYNC_FLUSH - Z_FULL_FLUSH - Z_FINISH - Z_BLOCK - -=item :level - -These symbolic constants are used by the C<Level> option in the constructor. - - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - -=item :strategy - -These symbolic constants are used by the C<Strategy> option in the constructor. - - Z_FILTERED - Z_HUFFMAN_ONLY - Z_RLE - Z_FIXED - Z_DEFAULT_STRATEGY - -=item :zip_method - -These symbolic constants are used by the C<Method> option in the -constructor. - - ZIP_CM_STORE - ZIP_CM_DEFLATE - ZIP_CM_BZIP2 - - - - -=back - -=head1 EXAMPLES - -=head2 Apache::GZip Revisited - -See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> - - - -=head2 Working with Net::FTP - -See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Compress/Zip/Constants.pm b/ext/IO-Compress/lib/IO/Compress/Zip/Constants.pm deleted file mode 100644 index d16eb238ef..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Zip/Constants.pm +++ /dev/null @@ -1,105 +0,0 @@ -package IO::Compress::Zip::Constants; - -use strict ; -use warnings; - -require Exporter; - -our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS); - -$VERSION = '2.021'; - -@ISA = qw(Exporter); - -@EXPORT= qw( - - ZIP_CM_STORE - ZIP_CM_DEFLATE - ZIP_CM_BZIP2 - ZIP_CM_LZMA - ZIP_CM_PPMD - - ZIP_LOCAL_HDR_SIG - ZIP_DATA_HDR_SIG - ZIP_CENTRAL_HDR_SIG - ZIP_END_CENTRAL_HDR_SIG - ZIP64_END_CENTRAL_REC_HDR_SIG - ZIP64_END_CENTRAL_LOC_HDR_SIG - ZIP64_ARCHIVE_EXTRA_SIG - ZIP64_DIGITAL_SIGNATURE_SIG - - ZIP_GP_FLAG_ENCRYPTED_MASK - ZIP_GP_FLAG_STREAMING_MASK - ZIP_GP_FLAG_PATCHED_MASK - ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK - ZIP_GP_FLAG_LZMA_EOS_PRESENT - ZIP_GP_FLAG_LANGUAGE_ENCODING - - ZIP_EXTRA_ID_ZIP64 - ZIP_EXTRA_ID_EXT_TIMESTAMP - ZIP_EXTRA_ID_INFO_ZIP_UNIX2 - ZIP_EXTRA_ID_INFO_ZIP_UNIXn - ZIP_EXTRA_ID_JAVA_EXE - - ZIP_OS_CODE_UNIX - ZIP_OS_CODE_DEFAULT - - ZIP_IFA_TEXT_MASK - - %ZIP_CM_MIN_VERSIONS - ZIP64_MIN_VERSION - - ); - -# Compression types supported -use constant ZIP_CM_STORE => 0 ; -use constant ZIP_CM_DEFLATE => 8 ; -use constant ZIP_CM_BZIP2 => 12 ; -use constant ZIP_CM_LZMA => 14 ; # Not Supported yet -use constant ZIP_CM_PPMD => 98 ; # Not Supported yet - -# General Purpose Flag -use constant ZIP_GP_FLAG_ENCRYPTED_MASK => (1 << 0) ; -use constant ZIP_GP_FLAG_STREAMING_MASK => (1 << 3) ; -use constant ZIP_GP_FLAG_PATCHED_MASK => (1 << 5) ; -use constant ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK => (1 << 6) ; -use constant ZIP_GP_FLAG_LZMA_EOS_PRESENT => (1 << 1) ; -use constant ZIP_GP_FLAG_LANGUAGE_ENCODING => (1 << 11) ; - -# Internal File Attributes -use constant ZIP_IFA_TEXT_MASK => 1; - -# Signatures for each of the headers -use constant ZIP_LOCAL_HDR_SIG => 0x04034b50; -use constant ZIP_DATA_HDR_SIG => 0x08074b50; -use constant ZIP_CENTRAL_HDR_SIG => 0x02014b50; -use constant ZIP_END_CENTRAL_HDR_SIG => 0x06054b50; -use constant ZIP64_END_CENTRAL_REC_HDR_SIG => 0x06064b50; -use constant ZIP64_END_CENTRAL_LOC_HDR_SIG => 0x07064b50; -use constant ZIP64_ARCHIVE_EXTRA_SIG => 0x08064b50; -use constant ZIP64_DIGITAL_SIGNATURE_SIG => 0x05054b50; - -use constant ZIP_OS_CODE_UNIX => 3; -use constant ZIP_OS_CODE_DEFAULT => 3; - -# Extra Field ID's -use constant ZIP_EXTRA_ID_ZIP64 => pack "v", 1; -use constant ZIP_EXTRA_ID_EXT_TIMESTAMP => "UT"; -use constant ZIP_EXTRA_ID_INFO_ZIP_UNIX2 => "Ux"; -use constant ZIP_EXTRA_ID_INFO_ZIP_UNIXn => "ux"; -use constant ZIP_EXTRA_ID_JAVA_EXE => pack "v", 0xCAFE; - -use constant ZIP64_MIN_VERSION => 45; - -%ZIP_CM_MIN_VERSIONS = ( - ZIP_CM_STORE() => 20, - ZIP_CM_DEFLATE() => 20, - ZIP_CM_BZIP2() => 46, - ZIP_CM_LZMA() => 63, - ); - - -1; - -__END__ - diff --git a/ext/IO-Compress/lib/IO/Compress/Zlib/Constants.pm b/ext/IO-Compress/lib/IO/Compress/Zlib/Constants.pm deleted file mode 100644 index d65fedc580..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Zlib/Constants.pm +++ /dev/null @@ -1,77 +0,0 @@ - -package IO::Compress::Zlib::Constants ; - -use strict ; -use warnings; -use bytes; - -require Exporter; - -our ($VERSION, @ISA, @EXPORT); - -$VERSION = '2.021'; - -@ISA = qw(Exporter); - -@EXPORT= qw( - - ZLIB_HEADER_SIZE - ZLIB_TRAILER_SIZE - - ZLIB_CMF_CM_OFFSET - ZLIB_CMF_CM_BITS - ZLIB_CMF_CM_DEFLATED - - ZLIB_CMF_CINFO_OFFSET - ZLIB_CMF_CINFO_BITS - ZLIB_CMF_CINFO_MAX - - ZLIB_FLG_FCHECK_OFFSET - ZLIB_FLG_FCHECK_BITS - - ZLIB_FLG_FDICT_OFFSET - ZLIB_FLG_FDICT_BITS - - ZLIB_FLG_LEVEL_OFFSET - ZLIB_FLG_LEVEL_BITS - - ZLIB_FLG_LEVEL_FASTEST - ZLIB_FLG_LEVEL_FAST - ZLIB_FLG_LEVEL_DEFAULT - ZLIB_FLG_LEVEL_SLOWEST - - ZLIB_FDICT_SIZE - - ); - -# Constant names derived from RFC1950 - -use constant ZLIB_HEADER_SIZE => 2; -use constant ZLIB_TRAILER_SIZE => 4; - -use constant ZLIB_CMF_CM_OFFSET => 0; -use constant ZLIB_CMF_CM_BITS => 0xF ; # 0b1111 -use constant ZLIB_CMF_CM_DEFLATED => 8; - -use constant ZLIB_CMF_CINFO_OFFSET => 4; -use constant ZLIB_CMF_CINFO_BITS => 0xF ; # 0b1111; -use constant ZLIB_CMF_CINFO_MAX => 7; - -use constant ZLIB_FLG_FCHECK_OFFSET => 0; -use constant ZLIB_FLG_FCHECK_BITS => 0x1F ; # 0b11111; - -use constant ZLIB_FLG_FDICT_OFFSET => 5; -use constant ZLIB_FLG_FDICT_BITS => 0x1 ; # 0b1; - -use constant ZLIB_FLG_LEVEL_OFFSET => 6; -use constant ZLIB_FLG_LEVEL_BITS => 0x3 ; # 0b11; - -use constant ZLIB_FLG_LEVEL_FASTEST => 0; -use constant ZLIB_FLG_LEVEL_FAST => 1; -use constant ZLIB_FLG_LEVEL_DEFAULT => 2; -use constant ZLIB_FLG_LEVEL_SLOWEST => 3; - -use constant ZLIB_FDICT_SIZE => 4; - - -1; diff --git a/ext/IO-Compress/lib/IO/Compress/Zlib/Extra.pm b/ext/IO-Compress/lib/IO/Compress/Zlib/Extra.pm deleted file mode 100644 index 72b4ddd370..0000000000 --- a/ext/IO-Compress/lib/IO/Compress/Zlib/Extra.pm +++ /dev/null @@ -1,198 +0,0 @@ -package IO::Compress::Zlib::Extra; - -require 5.004 ; - -use strict ; -use warnings; -use bytes; - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); - -$VERSION = '2.021'; - -use IO::Compress::Gzip::Constants 2.021 ; - -sub ExtraFieldError -{ - return $_[0]; - return "Error with ExtraField Parameter: $_[0]" ; -} - -sub validateExtraFieldPair -{ - my $pair = shift ; - my $strict = shift; - my $gzipMode = 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 $strict && $gzipMode && 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 parseRawExtra -{ - my $data = shift ; - my $extraRef = shift; - my $strict = shift; - my $gzipMode = 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("Truncated in FEXTRA Body Section") - 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("Truncated in FEXTRA Body Section") - if $offset + $subLen > $XLEN ; - - my $bad = validateExtraFieldPair( [$id, - substr($data, $offset, $subLen)], - $strict, $gzipMode ); - return $bad if $bad ; - push @$extraRef, [$id => substr($data, $offset, $subLen)] - if defined $extraRef;; - - $offset += $subLen ; - } - - - return undef ; -} - - -sub mkSubField -{ - my $id = shift ; - my $data = shift ; - - return $id . pack("v", length $data) . $data ; -} - -sub parseExtraField -{ - my $dataRef = $_[0]; - my $strict = $_[1]; - my $gzipMode = $_[2]; - #my $lax = @_ == 2 ? $_[1] : 1; - - - # ExtraField can be any of - # - # -ExtraField => $data - # - # -ExtraField => [$id1, $data1, - # $id2, $data2] - # ... - # ] - # - # -ExtraField => [ [$id1 => $data1], - # [$id2 => $data2], - # ... - # ] - # - # -ExtraField => { $id1 => $data1, - # $id2 => $data2, - # ... - # } - - if ( ! ref $dataRef ) { - - return undef - if ! $strict; - - return parseRawExtra($dataRef, undef, 1, $gzipMode); - } - - #my $data = $$dataRef; - my $data = $dataRef; - 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, $strict, $gzipMode) ; - return $bad if $bad ; - - $out .= mkSubField(@$pair); - } - } - 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]], - $strict, $gzipMode) ; - return $bad if $bad ; - - $out .= mkSubField($data->[$ix], $data->[$ix+1]); - } - } - } - elsif (ref $data eq 'HASH') { - while (my ($id, $info) = each %$data) { - my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode); - return $bad if $bad ; - - $out .= mkSubField($id, $info); - } - } - else { - return ExtraFieldError("Not a scalar, array ref or hash ref") ; - } - - return ExtraFieldError("Too Large") - if length $out > GZIP_FEXTRA_MAX_SIZE; - - $_[0] = $out ; - - return undef; -} - -1; - -__END__ diff --git a/ext/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm b/ext/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm deleted file mode 100644 index b2053aff10..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm +++ /dev/null @@ -1,112 +0,0 @@ -package IO::Uncompress::Adapter::Bunzip2; - -use strict; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(:Status); - -use Compress::Raw::Bzip2 2.021 ; - -our ($VERSION, @ISA); -$VERSION = '2.021'; - -sub mkUncompObject -{ - my $small = shift || 0; - my $verbosity = shift || 0; - - my ($inflate, $status) = new Compress::Raw::Bunzip2(1, 1, $small, $verbosity, 1); - - return (undef, "Could not create Inflation object: $status", $status) - if $status != BZ_OK ; - - return bless {'Inf' => $inflate, - 'CompSize' => 0, - 'UnCompSize' => 0, - 'Error' => '', - 'ConsumesInput' => 1, - } ; - -} - -sub uncompr -{ - my $self = shift ; - my $from = shift ; - my $to = shift ; - my $eof = shift ; - - my $inf = $self->{Inf}; - - my $status = $inf->bzinflate($from, $to); - $self->{ErrorNo} = $status; - - if ($status != BZ_OK && $status != BZ_STREAM_END ) - { - $self->{Error} = "Inflation Error: $status"; - return STATUS_ERROR; - } - - - return STATUS_OK if $status == BZ_OK ; - return STATUS_ENDSTREAM if $status == BZ_STREAM_END ; - return STATUS_ERROR ; -} - - -sub reset -{ - my $self = shift ; - - my ($inf, $status) = new Compress::Raw::Bunzip2(); - $self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ; - - if ($status != BZ_OK) - { - $self->{Error} = "Cannot create Inflate object: $status"; - return STATUS_ERROR; - } - - $self->{Inf} = $inf; - - return STATUS_OK ; -} - -sub compressedBytes -{ - my $self = shift ; - $self->{Inf}->compressedBytes(); -} - -sub uncompressedBytes -{ - my $self = shift ; - $self->{Inf}->uncompressedBytes(); -} - -sub crc32 -{ - my $self = shift ; - #$self->{Inf}->crc32(); -} - -sub adler32 -{ - my $self = shift ; - #$self->{Inf}->adler32(); -} - -sub sync -{ - my $self = shift ; - #( $self->{Inf}->inflateSync(@_) == BZ_OK) - # ? STATUS_OK - # : STATUS_ERROR ; -} - - -1; - -__END__ - diff --git a/ext/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm b/ext/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm deleted file mode 100644 index 0df174320a..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm +++ /dev/null @@ -1,105 +0,0 @@ -package IO::Uncompress::Adapter::Identity; - -use warnings; -use strict; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(:Status); - -our ($VERSION); - -$VERSION = '2.021'; - -use Compress::Raw::Zlib 2.021 (); - -sub mkUncompObject -{ - my $crc32 = 1; #shift ; - my $adler32 = shift; - - bless { 'CompSize' => 0, - 'UnCompSize' => 0, - 'wantCRC32' => $crc32, - 'CRC32' => Compress::Raw::Zlib::crc32(''), - 'wantADLER32'=> $adler32, - 'ADLER32' => Compress::Raw::Zlib::adler32(''), - 'ConsumesInput' => 1, - - } ; -} - -sub uncompr -{ - my $self = shift; - my $eof = $_[2]; - - 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::Zlib::adler32($_[0], $self->{ADLER32}) - if $self->{wantADLER32}; - - ${ $_[1] } .= ${ $_[0] }; - ${ $_[0] } = ""; - } - - return STATUS_ENDSTREAM if $eof; - 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 count -#{ -# my $self = shift ; -# return $self->{UnCompSize} ; -#} - -sub compressedBytes -{ - my $self = shift ; - return $self->{UnCompSize} ; -} - -sub uncompressedBytes -{ - my $self = shift ; - return $self->{UnCompSize} ; -} - -sub sync -{ - return STATUS_OK ; -} - -sub crc32 -{ - my $self = shift ; - return $self->{CRC32}; -} - -sub adler32 -{ - my $self = shift ; - return $self->{ADLER32}; -} - - -1; - -__END__ diff --git a/ext/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm b/ext/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm deleted file mode 100644 index d03148c0b4..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm +++ /dev/null @@ -1,158 +0,0 @@ -package IO::Uncompress::Adapter::Inflate; - -use strict; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(:Status); -use Compress::Raw::Zlib 2.021 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); - -our ($VERSION); -$VERSION = '2.021'; - - - -sub mkUncompObject -{ - my $crc32 = shift || 1; - my $adler32 = shift || 1; - my $scan = shift || 0; - - my $inflate ; - my $status ; - - if ($scan) - { - ($inflate, $status) = new Compress::Raw::Zlib::InflateScan - #LimitOutput => 1, - CRC32 => $crc32, - ADLER32 => $adler32, - WindowBits => - MAX_WBITS ; - } - else - { - ($inflate, $status) = new Compress::Raw::Zlib::Inflate - AppendOutput => 1, - LimitOutput => 1, - CRC32 => $crc32, - ADLER32 => $adler32, - WindowBits => - MAX_WBITS ; - } - - return (undef, "Could not create Inflation object: $status", $status) - if $status != Z_OK ; - - return bless {'Inf' => $inflate, - 'CompSize' => 0, - 'UnCompSize' => 0, - 'Error' => '', - 'ConsumesInput' => 1, - } ; - -} - -sub uncompr -{ - my $self = shift ; - my $from = shift ; - my $to = shift ; - my $eof = shift ; - - my $inf = $self->{Inf}; - - my $status = $inf->inflate($from, $to, $eof); - $self->{ErrorNo} = $status; - - if ($status != Z_OK && $status != Z_STREAM_END && $status != Z_BUF_ERROR) - { - $self->{Error} = "Inflation Error: $status"; - return STATUS_ERROR; - } - - return STATUS_OK if $status == Z_BUF_ERROR ; # ??? - return STATUS_OK if $status == Z_OK ; - return STATUS_ENDSTREAM if $status == Z_STREAM_END ; - return STATUS_ERROR ; -} - -sub reset -{ - my $self = shift ; - $self->{Inf}->inflateReset(); - - return STATUS_OK ; -} - -#sub count -#{ -# my $self = shift ; -# $self->{Inf}->inflateCount(); -#} - -sub crc32 -{ - my $self = shift ; - $self->{Inf}->crc32(); -} - -sub compressedBytes -{ - my $self = shift ; - $self->{Inf}->compressedBytes(); -} - -sub uncompressedBytes -{ - my $self = shift ; - $self->{Inf}->uncompressedBytes(); -} - -sub adler32 -{ - my $self = shift ; - $self->{Inf}->adler32(); -} - -sub sync -{ - my $self = shift ; - ( $self->{Inf}->inflateSync(@_) == Z_OK) - ? STATUS_OK - : STATUS_ERROR ; -} - - -sub getLastBlockOffset -{ - my $self = shift ; - $self->{Inf}->getLastBlockOffset(); -} - -sub getEndOffset -{ - my $self = shift ; - $self->{Inf}->getEndOffset(); -} - -sub resetLastBlockByte -{ - my $self = shift ; - $self->{Inf}->resetLastBlockByte(@_); -} - -sub createDeflateStream -{ - my $self = shift ; - my $deflate = $self->{Inf}->createDeflateStream(@_); - return bless {'Def' => $deflate, - 'CompSize' => 0, - 'UnCompSize' => 0, - 'Error' => '', - }, 'IO::Compress::Adapter::Deflate'; -} - -1; - - -__END__ - diff --git a/ext/IO-Compress/lib/IO/Uncompress/AnyInflate.pm b/ext/IO-Compress/lib/IO/Uncompress/AnyInflate.pm deleted file mode 100644 index e8ffc5c15b..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/AnyInflate.pm +++ /dev/null @@ -1,946 +0,0 @@ -package IO::Uncompress::AnyInflate ; - -# for RFC1950, RFC1951 or RFC1952 - -use strict; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(createSelfTiedObject); - -use IO::Uncompress::Adapter::Inflate 2.021 (); - - -use IO::Uncompress::Base 2.021 ; -use IO::Uncompress::Gunzip 2.021 ; -use IO::Uncompress::Inflate 2.021 ; -use IO::Uncompress::RawInflate 2.021 ; -use IO::Uncompress::Unzip 2.021 ; - -require Exporter ; - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); - -$VERSION = '2.021'; -$AnyInflateError = ''; - -@ISA = qw( Exporter IO::Uncompress::Base ); -@EXPORT_OK = qw( $AnyInflateError anyinflate ) ; -%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, \$AnyInflateError); - $obj->_create(undef, 0, @_); -} - -sub anyinflate -{ - my $obj = createSelfTiedObject(undef, \$AnyInflateError); - return $obj->_inf(@_) ; -} - -sub getExtraParams -{ - use IO::Compress::Base::Common 2.021 qw(:Parse); - return ( 'RawInflate' => [1, 1, Parse_boolean, 0] ) ; -} - -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 $got = shift ; - - my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject(); - - return $self->saveErrorString(undef, $errstr, $errno) - if ! defined $obj; - - *$self->{Uncomp} = $obj; - - my @possible = qw( Inflate Gunzip Unzip ); - unshift @possible, 'RawInflate' - if 1 || $got->value('RawInflate'); - - my $magic = $self->ckMagic( @possible ); - - if ($magic) { - *$self->{Info} = $self->readHeader($magic) - or return undef ; - - return 1; - } - - return 0 ; -} - - - -sub ckMagic -{ - my $self = shift; - my @names = @_ ; - - my $keep = ref $self ; - for my $class ( map { "IO::Uncompress::$_" } @names) - { - bless $self => $class; - my $magic = $self->ckMagic(); - - if ($magic) - { - #bless $self => $class; - return $magic ; - } - - $self->pushBack(*$self->{HeaderPending}) ; - *$self->{HeaderPending} = '' ; - } - - bless $self => $keep; - return undef; -} - -1 ; - -__END__ - - -=head1 NAME - -IO::Uncompress::AnyInflate - Uncompress zlib-based (zip, gzip) file/buffer - -=head1 SYNOPSIS - - use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; - - my $status = anyinflate $input => $output [,OPTS] - or die "anyinflate failed: $AnyInflateError\n"; - - my $z = new IO::Uncompress::AnyInflate $input [OPTS] - or die "anyinflate failed: $AnyInflateError\n"; - - $status = $z->read($buffer) - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - $line = $z->getline() - $char = $z->getc() - $char = $z->ungetc() - $char = $z->opened() - - $status = $z->inflateSync() - - $data = $z->trailingData() - $status = $z->nextStream() - $data = $z->getHeaderInfo() - $z->tell() - $z->seek($position, $whence) - $z->binmode() - $z->fileno() - $z->eof() - $z->close() - - $AnyInflateError ; - - # IO::File mode - - <$z> - read($z, $buffer); - read($z, $buffer, $length); - read($z, $buffer, $length, $offset); - tell($z) - seek($z, $position, $whence) - binmode($z) - fileno($z) - eof($z) - close($z) - -=head1 DESCRIPTION - -This module provides a Perl interface that allows the reading of -files/buffers that have been compressed in a number of formats that use the -zlib compression library. - -The formats supported are - -=over 5 - -=item RFC 1950 - -=item RFC 1951 (optionally) - -=item gzip (RFC 1952) - -=item zip - -=back - -The module will auto-detect which, if any, of the supported -compression formats is being used. - -=head1 Functional Interface - -A top-level function, C<anyinflate>, is provided to carry out -"one-shot" uncompression between buffers and/or files. For finer -control over the uncompression process, see the L</"OO Interface"> -section. - - use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; - - anyinflate $input => $output [,OPTS] - or die "anyinflate failed: $AnyInflateError\n"; - -The functional interface needs Perl5.005 or better. - -=head2 anyinflate $input => $output [, OPTS] - -C<anyinflate> expects at least two parameters, C<$input> and C<$output>. - -=head3 The C<$input> parameter - -The parameter, C<$input>, is used to define the source of -the compressed data. - -It can take one of the following forms: - -=over 5 - -=item A filename - -If the C<$input> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for reading and the input data -will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the input data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the input data will be read -from C<$$input>. - -=item An array reference - -If C<$input> is an array reference, 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<anyinflate> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -uncompressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the uncompressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the uncompressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the uncompressed data will be -stored in C<$$output>. - -=item An Array Reference - -If C<$output> is an array reference, the uncompressed data will be -pushed onto the array. - -=item An Output FileGlob - -If C<$output> is a string that is delimited by the characters "<" and ">" -C<anyinflate> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple compressed files/buffers and C<$output> is -a single file/buffer, after uncompression C<$output> will contain a -concatenation of all the uncompressed data from each of the input -files/buffers. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<anyinflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<anyinflate> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<anyinflate> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeOut => 0|1 >> - -When writing to a file or filehandle, set C<binmode> before writing to the -file. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=item C<< MultiStream => 0|1 >> - -If the input file/buffer contains multiple compressed data streams, this -option will uncompress the whole lot as a single data stream. - -Defaults to 0. - -=item C<< TrailingData => $scalar >> - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option. - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt.Compressed> and write the -uncompressed data to the file C<file1.txt>. - - use strict ; - use warnings ; - use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; - - my $input = "file1.txt.Compressed"; - my $output = "file1.txt"; - anyinflate $input => $output - or die "anyinflate failed: $AnyInflateError\n"; - -To read from an existing Perl filehandle, C<$input>, and write the -uncompressed data to a buffer, C<$buffer>. - - use strict ; - use warnings ; - use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; - use IO::File ; - - my $input = new IO::File "<file1.txt.Compressed" - or die "Cannot open 'file1.txt.Compressed': $!\n" ; - my $buffer ; - anyinflate $input => \$buffer - or die "anyinflate failed: $AnyInflateError\n"; - -To uncompress all files in the directory "/my/home" that match "*.txt.Compressed" and store the compressed data in the same directory - - use strict ; - use warnings ; - use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; - - anyinflate '</my/home/*.txt.Compressed>' => '</my/home/#1.txt>' - or die "anyinflate failed: $AnyInflateError\n"; - -and if you want to compress each file one at a time, this will do the trick - - use strict ; - use warnings ; - use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; - - for my $input ( glob "/my/home/*.txt.Compressed" ) - { - my $output = $input; - $output =~ s/.Compressed// ; - anyinflate $input => $output - or die "Error compressing '$input': $AnyInflateError\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for IO::Uncompress::AnyInflate is shown below - - my $z = new IO::Uncompress::AnyInflate $input [OPTS] - or die "IO::Uncompress::AnyInflate failed: $AnyInflateError\n"; - -Returns an C<IO::Uncompress::AnyInflate> object on success and undef on failure. -The variable C<$AnyInflateError> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Uncompress::AnyInflate can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal input file operations can be carried out with -C<$z>. For example, to read a line from a compressed file/buffer you can -use either of these forms - - $line = $z->getline(); - $line = <$z>; - -The mandatory parameter C<$input> is used to determine the source of the -compressed data. This parameter can take one of three forms. - -=over 5 - -=item A filename - -If the C<$input> parameter is a scalar, it is assumed to be a filename. This -file will be opened for reading and the compressed data will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the compressed data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the compressed data will be read from -C<$$output>. - -=back - -=head2 Constructor Options - -The option names defined below are case insensitive and can be optionally -prefixed by a '-'. So all of the following are valid - - -AutoClose - -autoclose - AUTOCLOSE - autoclose - -OPTS is a combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$input> parameter is a filehandle. If -specified, and the value is true, it will result in the file being closed once -either the C<close> method is called or the IO::Uncompress::AnyInflate object is -destroyed. - -This parameter defaults to 0. - -=item C<< MultiStream => 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 C<< Prime => $string >> - -This option will uncompress the contents of C<$string> before processing the -input file/buffer. - -This option can be useful when the compressed data is embedded in another -file/data structure and it is not possible to work out where the compressed -data begins without having to read the first few bytes. If this is the -case, the uncompression can be I<primed> with these bytes using this -option. - -=item C<< Transparent => 0|1 >> - -If this option is set and the input file/buffer is not compressed data, -the module will allow reading of it anyway. - -In addition, if the input file/buffer does contain compressed data and -there is non-compressed data immediately following it, setting this option -will make this module treat the whole file/bufffer as a single data stream. - -This option defaults to 1. - -=item C<< BlockSize => $num >> - -When reading the compressed input data, IO::Uncompress::AnyInflate will read it in -blocks of C<$num> bytes. - -This option defaults to 4096. - -=item C<< InputLength => $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 C<< Append => 0|1 >> - -This option controls what the C<read> method does with uncompressed data. - -If set to 1, all uncompressed data will be appended to the output parameter -of the C<read> method. - -If set to 0, the contents of the output parameter of the C<read> method -will be overwritten by the uncompressed data. - -Defaults to 0. - -=item C<< Strict => 0|1 >> - -This option controls whether the extra checks defined below are used when -carrying out the decompression. When Strict is on, the extra tests are -carried out, when Strict is off they are not. - -The default for this option is off. - -If the input is an RFC 1950 data stream, the following will be checked: - -=over 5 - -=item 1 - -The ADLER32 checksum field must be present. - -=item 2 - -The value of the ADLER32 field read must match the adler32 value of the -uncompressed data actually contained in the file. - -=back - -If the input is a gzip (RFC 1952) data stream, the following will be checked: - -=over 5 - -=item 1 - -If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the -header must match the crc16 value of the gzip header actually read. - -=item 2 - -If the gzip header contains a name field (FNAME) it consists solely of ISO -8859-1 characters. - -=item 3 - -If the gzip header contains a comment field (FCOMMENT) it consists solely -of ISO 8859-1 characters plus line-feed. - -=item 4 - -If the gzip FEXTRA header field is present it must conform to the sub-field -structure as defined in RFC 1952. - -=item 5 - -The CRC32 and ISIZE trailer fields must be present. - -=item 6 - -The value of the CRC32 field read must match the crc32 value of the -uncompressed data actually contained in the gzip file. - -=item 7 - -The value of the ISIZE fields read must match the length of the -uncompressed data actually read from the file. - -=back - -=item C<< RawInflate => 0|1 >> - -When auto-detecting the compressed format, try to test for raw-deflate (RFC -1951) content using the C<IO::Uncompress::RawInflate> module. - -The reason this is not default behaviour is because RFC 1951 content can -only be detected by attempting to uncompress it. This process is error -prone and can result is false positives. - -Defaults to 0. - -=item C<< ParseExtra => 0|1 >> -If the gzip FEXTRA header field is present and this option is set, it will -force the module to check that it conforms to the sub-field structure as -defined in RFC 1952. - -If the C<Strict> is on it will automatically enable this option. - -Defaults to 0. - -=back - -=head2 Examples - -TODO - -=head1 Methods - -=head2 read - -Usage is - - $status = $z->read($buffer) - -Reads a block of compressed data (the size the the compressed block is -determined by the C<Buffer> option in the constructor), uncompresses it and -writes any uncompressed data into C<$buffer>. If the C<Append> parameter is -set in the constructor, the uncompressed data will be appended to the -C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 read - -Usage is - - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - - $status = read($z, $buffer, $length) - $status = read($z, $buffer, $length, $offset) - -Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. - -The main difference between this form of the C<read> method and the -previous one, is that this one will attempt to return I<exactly> C<$length> -bytes. The only circumstances that this function will not is if end-of-file -or an IO error is encountered. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 getline - -Usage is - - $line = $z->getline() - $line = <$z> - -Reads a single line. - -This method fully supports the use of of the variable C<$/> (or -C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to -determine what constitutes an end of line. Paragraph mode, record mode and -file slurp mode are all supported. - -=head2 getc - -Usage is - - $char = $z->getc() - -Read a single character. - -=head2 ungetc - -Usage is - - $char = $z->ungetc($string) - -=head2 inflateSync - -Usage is - - $status = $z->inflateSync() - -TODO - -=head2 getHeaderInfo - -Usage is - - $hdr = $z->getHeaderInfo(); - @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<seek> functionality, with the restriction -that it is only legal to seek forward in the input file/buffer. -It is a fatal error to attempt to seek backward. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<EXPR> 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, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<undef>. - -=head2 close - - $z->close() ; - close $z ; - -Closes the output file/buffer. - -For most versions of Perl this method will be automatically invoked if -the IO::Uncompress::AnyInflate object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Uncompress::AnyInflate -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 nextStream - -Usage is - - my $status = $z->nextStream(); - -Skips to the next compressed data stream in the input file/buffer. If a new -compressed data stream is found, the eof marker will be cleared and C<$.> -will be reset to 0. - -Returns 1 if a new stream was found, 0 if none was found, and -1 if an -error was encountered. - -=head2 trailingData - -Usage is - - my $data = $z->trailingData(); - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. It only makes sense to call -this method once the end of the compressed data stream has been -encountered. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option in the constructor. - -=head1 Importing - -No symbolic constants are required by this IO::Uncompress::AnyInflate at present. - -=over 5 - -=item :all - -Imports C<anyinflate> and C<$AnyInflateError>. -Same as doing this - - use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; - -=back - -=head1 EXAMPLES - -=head2 Working with Net::FTP - -See L<IO::Uncompress::AnyInflate::FAQ|IO::Uncompress::AnyInflate::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm b/ext/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm deleted file mode 100644 index cc1ba24b47..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm +++ /dev/null @@ -1,960 +0,0 @@ -package IO::Uncompress::AnyUncompress ; - -use strict; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(createSelfTiedObject); - -use IO::Uncompress::Base 2.021 ; - - -require Exporter ; - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError); - -$VERSION = '2.021'; -$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. - -BEGIN -{ - eval ' use IO::Uncompress::Adapter::Inflate 2.021 ;'; - eval ' use IO::Uncompress::Adapter::Bunzip2 2.021 ;'; - eval ' use IO::Uncompress::Adapter::LZO 2.021 ;'; - eval ' use IO::Uncompress::Adapter::Lzf 2.021 ;'; - eval ' use IO::Uncompress::Adapter::UnLzma 2.020 ;'; - eval ' use IO::Uncompress::Adapter::UnXz 2.020 ;'; - - eval ' use IO::Uncompress::Bunzip2 2.021 ;'; - eval ' use IO::Uncompress::UnLzop 2.021 ;'; - eval ' use IO::Uncompress::Gunzip 2.021 ;'; - eval ' use IO::Uncompress::Inflate 2.021 ;'; - eval ' use IO::Uncompress::RawInflate 2.021 ;'; - eval ' use IO::Uncompress::Unzip 2.021 ;'; - eval ' use IO::Uncompress::UnLzf 2.021 ;'; - eval ' use IO::Uncompress::UnLzma 2.018 ;'; - eval ' use IO::Uncompress::UnXz 2.018 ;'; -} - -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 -{ - use IO::Compress::Base::Common 2.021 qw(:Parse); - return ( 'RawInflate' => [1, 1, Parse_boolean, 0] ) ; -} - -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 $got = shift ; - - my $magic ; - - # try zlib first - if (defined $IO::Uncompress::RawInflate::VERSION ) - { - my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject(); - - return $self->saveErrorString(undef, $errstr, $errno) - if ! defined $obj; - - *$self->{Uncomp} = $obj; - - my @possible = qw( Inflate Gunzip Unzip ); - unshift @possible, 'RawInflate' - if $got->value('RawInflate'); - - $magic = $self->ckMagic( @possible ); - - if ($magic) { - *$self->{Info} = $self->readHeader($magic) - or return undef ; - - return 1; - } - } - -# if (defined $IO::Uncompress::UnLzma::VERSION ) -# { -# my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnLzma::mkUncompObject(); -# -# return $self->saveErrorString(undef, $errstr, $errno) -# if ! defined $obj; -# -# *$self->{Uncomp} = $obj; -# -# my @possible = qw( UnLzma ); -# #unshift @possible, 'RawInflate' -# # if $got->value('RawInflate'); -# -# if ( *$self->{Info} = $self->ckMagic( @possible )) -# { -# return 1; -# } -# } - - if (defined $IO::Uncompress::UnXz::VERSION and - $magic = $self->ckMagic('UnXz')) { - *$self->{Info} = $self->readHeader($magic) - or return undef ; - - my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnXz::mkUncompObject(); - - return $self->saveErrorString(undef, $errstr, $errno) - if ! defined $obj; - - *$self->{Uncomp} = $obj; - - return 1; - } - - 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; - } - - if (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; - } - - if (defined $IO::Uncompress::UnLzf::VERSION and - $magic = $self->ckMagic('UnLzf')) { - - *$self->{Info} = $self->readHeader($magic) - or return undef ; - - my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Lzf::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 - Uncompress gzip, zip, bzip2 or lzop file/buffer - -=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() - - $data = $z->trailingData() - $status = $z->nextStream() - $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 - -This module provides a Perl interface that allows the reading of -files/buffers that have been compressed with a variety of compression -libraries. - -The formats supported are: - -=over 5 - -=item RFC 1950 - -=item RFC 1951 (optionally) - -=item gzip (RFC 1952) - -=item zip - -=item bzip2 - -=item lzop - -=item lzf - -=back - -The module will auto-detect which, if any, of the supported -compression formats is being used. - -=head1 Functional Interface - -A top-level function, C<anyuncompress>, is provided to carry out -"one-shot" uncompression between buffers and/or files. For finer -control over the uncompression process, see the L</"OO Interface"> -section. - - use IO::Uncompress::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<anyuncompress> 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<anyuncompress> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -uncompressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the uncompressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the uncompressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the uncompressed data will be -stored in C<$$output>. - -=item 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<anyuncompress> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple compressed files/buffers and C<$output> is -a single file/buffer, after uncompression C<$output> will contain a -concatenation of all the uncompressed data from each of the input -files/buffers. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<anyuncompress>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<anyuncompress> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<anyuncompress> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeOut => 0|1 >> - -When writing to a file or filehandle, set C<binmode> before writing to the -file. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=item C<< MultiStream => 0|1 >> - -If the input file/buffer contains multiple compressed data streams, this -option will uncompress the whole lot as a single data stream. - -Defaults to 0. - -=item C<< TrailingData => $scalar >> - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option. - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt.Compressed> and write the -uncompressed data to the file C<file1.txt>. - - 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 "<file1.txt.Compressed" - or die "Cannot open 'file1.txt.Compressed': $!\n" ; - my $buffer ; - anyuncompress $input => \$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 '</my/home/*.txt.Compressed>' => '</my/home/#1.txt>' - 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<IO::Uncompress::AnyUncompress> 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<IO::File|IO::File> filehandle. -This means that all normal input file operations can be carried out with -C<$z>. For example, to read a line from a compressed file/buffer you can -use either of these forms - - $line = $z->getline(); - $line = <$z>; - -The mandatory parameter C<$input> is used to determine the source of the -compressed data. This parameter can take one of three forms. - -=over 5 - -=item A filename - -If the C<$input> parameter is a scalar, it is assumed to be a filename. This -file will be opened for reading and the compressed data will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the compressed data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the compressed data will be read from -C<$$output>. - -=back - -=head2 Constructor Options - -The option names defined below are case insensitive and can be optionally -prefixed by a '-'. So all of the following are valid - - -AutoClose - -autoclose - AUTOCLOSE - autoclose - -OPTS is a combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$input> parameter is a filehandle. If -specified, and the value is true, it will result in the file being closed once -either the C<close> method is called or the IO::Uncompress::AnyUncompress object is -destroyed. - -This parameter defaults to 0. - -=item C<< MultiStream => 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 C<< Prime => $string >> - -This option will uncompress the contents of C<$string> before processing the -input file/buffer. - -This option can be useful when the compressed data is embedded in another -file/data structure and it is not possible to work out where the compressed -data begins without having to read the first few bytes. If this is the -case, the uncompression can be I<primed> with these bytes using this -option. - -=item C<< Transparent => 0|1 >> - -If this option is set and the input file/buffer is not compressed data, -the module will allow reading of it anyway. - -In addition, if the input file/buffer does contain compressed data and -there is non-compressed data immediately following it, setting this option -will make this module treat the whole file/bufffer as a single data stream. - -This option defaults to 1. - -=item C<< BlockSize => $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 C<< InputLength => $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 C<< Append => 0|1 >> - -This option controls what the C<read> method does with uncompressed data. - -If set to 1, all uncompressed data will be appended to the output parameter -of the C<read> method. - -If set to 0, the contents of the output parameter of the C<read> method -will be overwritten by the uncompressed data. - -Defaults to 0. - -=item C<< Strict => 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. - -=item C<< RawInflate => 0|1 >> - -When auto-detecting the compressed format, try to test for raw-deflate (RFC -1951) content using the C<IO::Uncompress::RawInflate> module. - -The reason this is not default behaviour is because RFC 1951 content can -only be detected by attempting to uncompress it. This process is error -prone and can result is false positives. - -Defaults to 0. - -=back - -=head2 Examples - -TODO - -=head1 Methods - -=head2 read - -Usage is - - $status = $z->read($buffer) - -Reads a block of compressed data (the size the the compressed block is -determined by the C<Buffer> option in the constructor), uncompresses it and -writes any uncompressed data into C<$buffer>. If the C<Append> parameter is -set in the constructor, the uncompressed data will be appended to the -C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 read - -Usage is - - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - - $status = read($z, $buffer, $length) - $status = read($z, $buffer, $length, $offset) - -Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. - -The main difference between this form of the C<read> method and the -previous one, is that this one will attempt to return I<exactly> C<$length> -bytes. The only circumstances that this function will not is if end-of-file -or an IO error is encountered. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 getline - -Usage is - - $line = $z->getline() - $line = <$z> - -Reads a single line. - -This method fully supports the use of of the variable C<$/> (or -C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to -determine what constitutes an end of line. Paragraph mode, record mode and -file slurp mode are all 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<seek> functionality, with the restriction -that it is only legal to seek forward in the input file/buffer. -It is a fatal error to attempt to seek backward. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<EXPR> 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, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<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<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Uncompress::AnyUncompress -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 nextStream - -Usage is - - my $status = $z->nextStream(); - -Skips to the next compressed data stream in the input file/buffer. If a new -compressed data stream is found, the eof marker will be cleared and C<$.> -will be reset to 0. - -Returns 1 if a new stream was found, 0 if none was found, and -1 if an -error was encountered. - -=head2 trailingData - -Usage is - - my $data = $z->trailingData(); - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. It only makes sense to call -this method once the end of the compressed data stream has been -encountered. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option in the constructor. - -=head1 Importing - -No symbolic constants are required by this IO::Uncompress::AnyUncompress at present. - -=over 5 - -=item :all - -Imports C<anyuncompress> and C<$AnyUncompressError>. -Same as doing this - - use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; - -=back - -=head1 EXAMPLES - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Uncompress/Base.pm b/ext/IO-Compress/lib/IO/Uncompress/Base.pm deleted file mode 100644 index 8459ce0e05..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/Base.pm +++ /dev/null @@ -1,1474 +0,0 @@ - -package IO::Uncompress::Base ; - -use strict ; -use warnings; -use bytes; - -our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS); -@ISA = qw(Exporter IO::File); - - -$VERSION = '2.021'; - -use constant G_EOF => 0 ; -use constant G_ERR => -1 ; - -use IO::Compress::Base::Common 2.021 ; -#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 (defined *$self->{InputLength}) { - return 0 - if *$self->{InputLengthRemaining} <= 0 ; - $size = min($size, *$self->{InputLengthRemaining}); - } - - 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 - if defined *$self->{InputLength}; - - return length $$out ; - } - $offset = length $$out ; - } - - my $get_size = $size - $offset ; - - if (defined *$self->{FH}) { - if ($offset) { - # Not using this - # - # *$self->{FH}->read($$out, $get_size, $offset); - # - # because the filehandle may not support the offset parameter - # An example is Net::FTP - my $tmp = ''; - *$self->{FH}->read($tmp, $get_size) && - (substr($$out, $offset) = $tmp); - } - else - { *$self->{FH}->read($$out, $get_size) } - } - 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); - if (*$self->{ConsumeInput}) - { substr($$buf, 0, $get_size) = '' } - else - { *$self->{BufferOffset} += length($$out) - $offset } - } - - *$self->{InputLengthRemaining} -= length($$out) #- $offset - if defined *$self->{InputLength}; - - $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} ; - *$self->{InputLengthRemaining} += length($_[0]); - } - 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} || *$self->{PushMode}; - - if (defined *$self->{FH}) - { - # Could use - # - # *$self->{FH}->eof() - # - # here, but this can cause trouble if - # the filehandle is itself a tied handle, but it uses sysread. - # Then we get into mixing buffered & non-buffered IO, which will cause trouble - - my $info = $self->getErrInfo(); - - my $buffer = ''; - my $status = $self->smartRead(\$buffer, 1); - $self->pushBack($buffer) if length $buffer; - $self->setErrInfo($info); - - return $status == 0 ; - } - elsif (defined *$self->{InputEvent}) - { *$self->{EventEof} } - else - { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) } -} - -sub clearError -{ - my $self = shift ; - - *$self->{ErrorNo} = 0 ; - ${ *$self->{Error} } = '' ; -} - -sub getErrInfo -{ - my $self = shift ; - - return [ *$self->{ErrorNo}, ${ *$self->{Error} } ] ; -} - -sub setErrInfo -{ - my $self = shift ; - my $ref = shift; - - *$self->{ErrorNo} = $ref->[0] ; - ${ *$self->{Error} } = $ref->[1] ; -} - -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 TruncatedTrailer -{ - my ($self) = shift; - return $self->TrailerError("Truncated in $_[0] Section"); -} - -sub postCheckParams -{ - return 1; -} - -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], - '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], - #'Encode' => [1, 1, Parse_any, undef], - - #'ConsumeInput' => [1, 1, Parse_boolean, 0], - - $self->getExtraParams(), - - #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0, - # ContinueAfterEof - } ; - - $Valid->{TrailingData} = [1, 1, Parse_writable_scalar, undef] - if *$self->{OneShot} ; - - $got->parse($Valid, @_ ) - or $self->croakError("${class}: $got->{Error}") ; - - $self->postCheckParams($got) - or $self->croakError("${class}: " . $self->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 ; - - *$obj->{OneShot} = 0 ; - - 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 - *$obj->{FH}->seek(0, SEEK_SET) - if $got->value('Scan'); - } - else { - no warnings ; - 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 ; - } - - if ($got->parsed('Encode')) { - my $want_encoding = $got->value('Encode'); - *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding); - } - - - *$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->{BlockSize} = $got->value('BlockSize'); - *$obj->{Append} = $got->value('Append'); - *$obj->{AppendOutput} = $append_mode || $got->value('Append'); - *$obj->{ConsumeInput} = $got->value('ConsumeInput'); - *$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') ; - *$obj->{Type} = ''; - *$obj->{Prime} = $got->value('Prime') || '' ; - *$obj->{Pending} = ''; - *$obj->{Plain} = 0; - *$obj->{PlainBytesRead} = 0; - *$obj->{InflatedBytesRead} = 0; - *$obj->{UnCompSize} = new U64; - *$obj->{CompSize} = new U64; - *$obj->{TotalInflatedBytesRead} = 0; - *$obj->{NewStream} = 0 ; - *$obj->{EventEof} = 0 ; - *$obj->{ClassName} = $class ; - *$obj->{Params} = $got ; - - if (*$obj->{ConsumeInput}) { - *$obj->{InNew} = 0; - *$obj->{Closed} = 0; - return $obj - } - - my $status = $obj->mkUncomp($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' ) -# { -# return $self->saveErrorString(1, "$from: input filename is undef or null string", STATUS_ERROR) -# if ! defined $_[0] || $_[0] eq '' ; -# -# if ($_[0] ne '-' && ! -e $_[0] ) -# { -# return $self->saveErrorString(1, -# "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 IO::Compress::Base::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 ; - - if ($got->parsed('TrailingData')) - { - *$obj->{TrailingData} = $got->value('TrailingData'); - } - - *$obj->{MultiStream} = $got->value('MultiStream'); - $got->value('MultiStream', 0); - - $x->{Got} = $got ; - -# if ($x->{Hash}) -# { -# while (my($k, $v) = each %$input) -# { -# $v = \$input->{$k} -# unless defined $v ; -# -# $obj->_singleTarget($x, $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, $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, $in, $output, @_) - or return undef ; - } - - return 1 ; - } - - # finally the 1 to 1 and n to 1 - return $obj->_singleTarget($x, $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 $input = shift; - my $output = shift; - - my $buff = ''; - $x->{buff} = \$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, $output) - or return undef; - } - else - { - for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) - { - defined $self->_rd2($x, $element, $output) - 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, $!); - delete $x->{fh}; - } - - return 1 ; -} - -sub _rd2 -{ - my $self = shift ; - my $x = shift ; - my $input = shift; - my $output = shift; - - my $z = createSelfTiedObject($x->{Class}, *$self->{Error}); - - $z->_create($x->{Got}, 1, $input, @_) - or return undef ; - - my $status ; - my $fh = $x->{fh}; - - while (1) { - - 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} } = '' ; - } - } - - if (! $x->{oneOutput} ) { - my $ot = $x->{outType} ; - - if ($ot eq 'array') - { push @$output, $x->{buff} } - elsif ($ot eq 'hash') - { $output->{$input} = $x->{buff} } - - my $buff = ''; - $x->{buff} = \$buff; - } - - last if $status < 0 || $z->smartEof(); - #last if $status < 0 ; - - last - unless *$self->{MultiStream}; - - $status = $z->nextStream(); - - last - unless $status == 1 ; - } - - return $z->closeError(undef) - if $status < 0 ; - - ${ *$self->{TrailingData} } = $z->trailingData() - if defined *$self->{TrailingData} ; - - $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->gotoNextStream() > 0 - or return G_ERR; - - # 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 $beforeC_len = length $temp_buf; - my $before_len = defined $$buffer ? length $$buffer : 0 ; - $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer, - defined *$self->{CompressedInputLengthDone} || - $self->smartEof(), $outSize); - - # Remember the input buffer if it wasn't consumed completely - $self->pushBack($temp_buf) if *$self->{Uncomp}{ConsumesInput}; - - return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo}) - if $self->saveStatus($status) == STATUS_ERROR; - - $self->postBlockChk($buffer, $before_len) == STATUS_OK - or return G_ERR; - - $buf_len = defined $$buffer ? length($$buffer) - $before_len : 0; - - *$self->{CompSize}->add($beforeC_len - length $temp_buf) ; - - *$self->{InflatedBytesRead} += $buf_len ; - *$self->{TotalInflatedBytesRead} += $buf_len ; - *$self->{UnCompSize}->add($buf_len) ; - - $self->filterUncompressed($buffer); - - if (*$self->{Encoding}) { - $$buffer = *$self->{Encoding}->decode($$buffer); - } - } - - 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) ; - } - - # TODO - if want to file file pointer, do it here - - if (! $self->smartEof()) { - *$self->{NewStream} = 1 ; - - if (*$self->{MultiStream}) { - *$self->{EndStream} = 0 ; - return $buf_len ; - } - } - - } - - - # return the number of uncompressed bytes read - return $buf_len ; -} - -sub reset -{ - my $self = shift ; - - return *$self->{Uncomp}->reset(); -} - -sub filterUncompressed -{ -} - -#sub isEndStream -#{ -# my $self = shift ; -# return *$self->{NewStream} || -# *$self->{EndStream} ; -#} - -sub nextStream -{ - my $self = shift ; - - my $status = $self->gotoNextStream(); - $status == 1 - or return $status ; - - *$self->{TotalInflatedBytesRead} = 0 ; - *$self->{LineNo} = $. = 0; - - return 1; -} - -sub gotoNextStream -{ - my $self = shift ; - - if (! *$self->{NewStream}) { - my $status = 1; - my $buffer ; - - # TODO - make this more efficient if know the offset for the end of - # the stream and seekable - $status = $self->read($buffer) - while $status > 0 ; - - return $status - if $status < 0; - } - - *$self->{NewStream} = 0 ; - *$self->{EndStream} = 0 ; - $self->reset(); - *$self->{UnCompSize}->reset(); - *$self->{CompSize}->reset(); - - my $magic = $self->ckMagic(); - #*$self->{EndStream} = 0 ; - - if ( ! defined $magic) { - if (! *$self->{Transparent} ) - { - *$self->{EndStream} = 1 ; - return 0; - } - - $self->clearError(); - *$self->{Type} = 'plain'; - *$self->{Plain} = 1; - $self->pushBack(*$self->{HeaderPending}) ; - } - else - { - *$self->{Info} = $self->readHeader($magic); - - if ( ! defined *$self->{Info} ) { - *$self->{EndStream} = 1 ; - return -1; - } - } - - push @{ *$self->{InfoList} }, *$self->{Info} ; - - return 1; -} - -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} ; - - my $buffer ; - - 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; - - if (! *$self->{AppendOutput}) { - if (! $offset) { - $$buffer = '' ; - } - else { - if ($offset > length($$buffer)) { - $$buffer .= "\x00" x ($offset - length($$buffer)); - } - else { - substr($$buffer, $offset) = ''; - } - } - } - - return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; - - # 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 ; - - # 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} ; - *$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 ; - - return 0 - if $length == 0 ; - - $$buffer = '' - if ! defined $$buffer; - - $offset = length $$buffer - if *$self->{AppendOutput} ; - - *$self->{Pending} = $out_buffer; - $out_buffer = \*$self->{Pending} ; - - #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ; - substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ; - substr($$out_buffer, 0, $length) = '' ; - - return $length ; -} - -sub _getline -{ - my $self = shift ; - - # Slurp Mode - if ( ! defined $/ ) { - my $data ; - 1 while $self->read($data) > 0 ; - return \$data ; - } - - # Record Mode - if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) { - my $reclen = ${$/} ; - my $data ; - $self->read($data, $reclen) ; - return \$data ; - } - - # Paragraph Mode - if ( ! length $/ ) { - my $paragraph ; - while ($self->read($paragraph) > 0 ) { - if ($paragraph =~ s/^(.*?\n\n+)//s) { - *$self->{Pending} = $paragraph ; - my $par = $1 ; - return \$par ; - } - } - return \$paragraph; - } - - # $/ isn't empty, or a reference, so it's Line Mode. - { - my $line ; - my $offset; - my $p = \*$self->{Pending} ; - - if (length(*$self->{Pending}) && - ($offset = index(*$self->{Pending}, $/)) >=0) { - my $l = substr(*$self->{Pending}, 0, $offset + length $/ ); - substr(*$self->{Pending}, 0, $offset + length $/) = ''; - return \$l; - } - - while ($self->read($line) > 0 ) { - my $offset = index($line, $/); - if ($offset >= 0) { - my $l = substr($line, 0, $offset + length $/ ); - substr($line, 0, $offset + length $/) = ''; - $$p = $line; - return \$l; - } - } - - return \$line; - } -} - -sub getline -{ - my $self = shift; - my $current_append = *$self->{AppendOutput} ; - *$self->{AppendOutput} = 1; - my $lineref = $self->_getline(); - $. = ++ *$self->{LineNo} if defined $$lineref ; - *$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 ; - - if (defined *$self->{FH} || defined *$self->{InputEvent} ) { - return *$self->{Prime} ; - } - else { - my $buf = *$self->{Buffer} ; - my $offset = *$self->{BufferOffset} ; - return substr($$buf, $offset) ; - } -} - - -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 ; - local ($., $@, $!, $^E, $?); - - $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 - if ($target == $here) { - # On ordinary filehandles, seeking to the current - # position also clears the EOF condition, so we - # emulate this behavior locally while simultaneously - # cascading it to the underlying filehandle - if (*$self->{Plain}) { - *$self->{EndStream} = 0; - seek(*$self->{FH},0,1) if *$self->{FH}; - } - return 1; - } - - # 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 $got; - while (($got = $self->read(my $buffer, min($offset, *$self->{BlockSize})) ) > 0) - { - $offset -= $got; - last if $offset == 0 ; - } - - $here = $self->tell() ; - return $offset == 0 ? 1 : 0 ; -} - -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::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<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Uncompress/Bunzip2.pm b/ext/IO-Compress/lib/IO/Uncompress/Bunzip2.pm deleted file mode 100644 index ce483ea738..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/Bunzip2.pm +++ /dev/null @@ -1,858 +0,0 @@ -package IO::Uncompress::Bunzip2 ; - -use strict ; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(:Status createSelfTiedObject); - -use IO::Uncompress::Base 2.021 ; -use IO::Uncompress::Adapter::Bunzip2 2.021 ; - -require Exporter ; -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error); - -$VERSION = '2.021'; -$Bunzip2Error = ''; - -@ISA = qw( Exporter IO::Uncompress::Base ); -@EXPORT_OK = qw( $Bunzip2Error bunzip2 ) ; -#%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ; -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; -#Exporter::export_ok_tags('all'); - - -sub new -{ - my $class = shift ; - my $obj = createSelfTiedObject($class, \$Bunzip2Error); - - $obj->_create(undef, 0, @_); -} - -sub bunzip2 -{ - my $obj = createSelfTiedObject(undef, \$Bunzip2Error); - return $obj->_inf(@_); -} - -sub getExtraParams -{ - my $self = shift ; - - use IO::Compress::Base::Common 2.021 qw(:Parse); - - return ( - 'Verbosity' => [1, 1, Parse_boolean, 0], - 'Small' => [1, 1, Parse_boolean, 0], - ); -} - - -sub ckParams -{ - my $self = shift ; - my $got = shift ; - - return 1; -} - -sub mkUncomp -{ - my $self = shift ; - my $got = shift ; - - my $magic = $self->ckMagic() - or return 0; - - *$self->{Info} = $self->readHeader($magic) - or return undef ; - - my $Small = $got->value('Small'); - my $Verbosity = $got->value('Verbosity'); - - my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Bunzip2::mkUncompObject( - $Small, $Verbosity); - - return $self->saveErrorString(undef, $errstr, $errno) - if ! defined $obj; - - *$self->{Uncomp} = $obj; - - return 1; - -} - - -sub ckMagic -{ - my $self = shift; - - my $magic ; - $self->smartReadExact(\$magic, 4); - - *$self->{HeaderPending} = $magic ; - - return $self->HeaderError("Header size is " . - 4 . " bytes") - if length $magic != 4; - - return $self->HeaderError("Bad Magic.") - if ! isBzip2Magic($magic) ; - - - *$self->{Type} = 'bzip2'; - return $magic; -} - -sub readHeader -{ - my $self = shift; - my $magic = shift ; - - $self->pushBack($magic); - *$self->{HeaderPending} = ''; - - - return { - 'Type' => 'bzip2', - 'FingerprintLength' => 4, - 'HeaderLength' => 4, - 'TrailerLength' => 0, - 'Header' => '$magic' - }; - -} - -sub chkTrailer -{ - return STATUS_OK; -} - - - -sub isBzip2Magic -{ - my $buffer = shift ; - return $buffer =~ /^BZh\d$/; -} - -1 ; - -__END__ - - -=head1 NAME - -IO::Uncompress::Bunzip2 - Read bzip2 files/buffers - -=head1 SYNOPSIS - - use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; - - my $status = bunzip2 $input => $output [,OPTS] - or die "bunzip2 failed: $Bunzip2Error\n"; - - my $z = new IO::Uncompress::Bunzip2 $input [OPTS] - or die "bunzip2 failed: $Bunzip2Error\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() - - $data = $z->trailingData() - $status = $z->nextStream() - $data = $z->getHeaderInfo() - $z->tell() - $z->seek($position, $whence) - $z->binmode() - $z->fileno() - $z->eof() - $z->close() - - $Bunzip2Error ; - - # 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 - -This module provides a Perl interface that allows the reading of -bzip2 files/buffers. - -For writing bzip2 files/buffers, see the companion module IO::Compress::Bzip2. - -=head1 Functional Interface - -A top-level function, C<bunzip2>, is provided to carry out -"one-shot" uncompression between buffers and/or files. For finer -control over the uncompression process, see the L</"OO Interface"> -section. - - use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; - - bunzip2 $input => $output [,OPTS] - or die "bunzip2 failed: $Bunzip2Error\n"; - -The functional interface needs Perl5.005 or better. - -=head2 bunzip2 $input => $output [, OPTS] - -C<bunzip2> 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<bunzip2> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -uncompressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the uncompressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the uncompressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the uncompressed data will be -stored in C<$$output>. - -=item 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<bunzip2> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple compressed files/buffers and C<$output> is -a single file/buffer, after uncompression C<$output> will contain a -concatenation of all the uncompressed data from each of the input -files/buffers. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<bunzip2>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<bunzip2> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<bunzip2> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeOut => 0|1 >> - -When writing to a file or filehandle, set C<binmode> before writing to the -file. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=item C<< MultiStream => 0|1 >> - -If the input file/buffer contains multiple compressed data streams, this -option will uncompress the whole lot as a single data stream. - -Defaults to 0. - -=item C<< TrailingData => $scalar >> - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option. - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt.bz2> and write the -compressed data to the file C<file1.txt>. - - use strict ; - use warnings ; - use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; - - my $input = "file1.txt.bz2"; - my $output = "file1.txt"; - bunzip2 $input => $output - or die "bunzip2 failed: $Bunzip2Error\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::Bunzip2 qw(bunzip2 $Bunzip2Error) ; - use IO::File ; - - my $input = new IO::File "<file1.txt.bz2" - or die "Cannot open 'file1.txt.bz2': $!\n" ; - my $buffer ; - bunzip2 $input => \$buffer - or die "bunzip2 failed: $Bunzip2Error\n"; - -To uncompress all files in the directory "/my/home" that match "*.txt.bz2" and store the compressed data in the same directory - - use strict ; - use warnings ; - use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; - - bunzip2 '</my/home/*.txt.bz2>' => '</my/home/#1.txt>' - or die "bunzip2 failed: $Bunzip2Error\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::Bunzip2 qw(bunzip2 $Bunzip2Error) ; - - for my $input ( glob "/my/home/*.txt.bz2" ) - { - my $output = $input; - $output =~ s/.bz2// ; - bunzip2 $input => $output - or die "Error compressing '$input': $Bunzip2Error\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for IO::Uncompress::Bunzip2 is shown below - - my $z = new IO::Uncompress::Bunzip2 $input [OPTS] - or die "IO::Uncompress::Bunzip2 failed: $Bunzip2Error\n"; - -Returns an C<IO::Uncompress::Bunzip2> object on success and undef on failure. -The variable C<$Bunzip2Error> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Uncompress::Bunzip2 can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal input file operations can be carried out with -C<$z>. For example, to read a line from a compressed file/buffer you can -use either of these forms - - $line = $z->getline(); - $line = <$z>; - -The mandatory parameter C<$input> is used to determine the source of the -compressed data. This parameter can take one of three forms. - -=over 5 - -=item A filename - -If the C<$input> parameter is a scalar, it is assumed to be a filename. This -file will be opened for reading and the compressed data will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the compressed data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the compressed data will be read from -C<$$output>. - -=back - -=head2 Constructor Options - -The option names defined below are case insensitive and can be optionally -prefixed by a '-'. So all of the following are valid - - -AutoClose - -autoclose - AUTOCLOSE - autoclose - -OPTS is a combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$input> parameter is a filehandle. If -specified, and the value is true, it will result in the file being closed once -either the C<close> method is called or the IO::Uncompress::Bunzip2 object is -destroyed. - -This parameter defaults to 0. - -=item C<< MultiStream => 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 C<< Prime => $string >> - -This option will uncompress the contents of C<$string> before processing the -input file/buffer. - -This option can be useful when the compressed data is embedded in another -file/data structure and it is not possible to work out where the compressed -data begins without having to read the first few bytes. If this is the -case, the uncompression can be I<primed> with these bytes using this -option. - -=item C<< Transparent => 0|1 >> - -If this option is set and the input file/buffer is not compressed data, -the module will allow reading of it anyway. - -In addition, if the input file/buffer does contain compressed data and -there is non-compressed data immediately following it, setting this option -will make this module treat the whole file/bufffer as a single data stream. - -This option defaults to 1. - -=item C<< BlockSize => $num >> - -When reading the compressed input data, IO::Uncompress::Bunzip2 will read it in -blocks of C<$num> bytes. - -This option defaults to 4096. - -=item C<< InputLength => $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 C<< Append => 0|1 >> - -This option controls what the C<read> method does with uncompressed data. - -If set to 1, all uncompressed data will be appended to the output parameter -of the C<read> method. - -If set to 0, the contents of the output parameter of the C<read> method -will be overwritten by the uncompressed data. - -Defaults to 0. - -=item C<< Strict => 0|1 >> - -This option is a no-op. - -=item C<< Small => 0|1 >> - -When non-zero this options will make bzip2 use a decompression algorithm -that uses less memory at the expense of increasing the amount of time -taken for decompression. - -Default is 0. - -=back - -=head2 Examples - -TODO - -=head1 Methods - -=head2 read - -Usage is - - $status = $z->read($buffer) - -Reads a block of compressed data (the size the the compressed block is -determined by the C<Buffer> option in the constructor), uncompresses it and -writes any uncompressed data into C<$buffer>. If the C<Append> parameter is -set in the constructor, the uncompressed data will be appended to the -C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 read - -Usage is - - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - - $status = read($z, $buffer, $length) - $status = read($z, $buffer, $length, $offset) - -Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. - -The main difference between this form of the C<read> method and the -previous one, is that this one will attempt to return I<exactly> C<$length> -bytes. The only circumstances that this function will not is if end-of-file -or an IO error is encountered. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 getline - -Usage is - - $line = $z->getline() - $line = <$z> - -Reads a single line. - -This method fully supports the use of of the variable C<$/> (or -C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to -determine what constitutes an end of line. Paragraph mode, record mode and -file slurp mode are all 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<seek> functionality, with the restriction -that it is only legal to seek forward in the input file/buffer. -It is a fatal error to attempt to seek backward. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<EXPR> 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, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<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::Bunzip2 object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Uncompress::Bunzip2 -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 nextStream - -Usage is - - my $status = $z->nextStream(); - -Skips to the next compressed data stream in the input file/buffer. If a new -compressed data stream is found, the eof marker will be cleared and C<$.> -will be reset to 0. - -Returns 1 if a new stream was found, 0 if none was found, and -1 if an -error was encountered. - -=head2 trailingData - -Usage is - - my $data = $z->trailingData(); - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. It only makes sense to call -this method once the end of the compressed data stream has been -encountered. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option in the constructor. - -=head1 Importing - -No symbolic constants are required by this IO::Uncompress::Bunzip2 at present. - -=over 5 - -=item :all - -Imports C<bunzip2> and C<$Bunzip2Error>. -Same as doing this - - use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; - -=back - -=head1 EXAMPLES - -=head2 Working with Net::FTP - -See L<IO::Uncompress::Bunzip2::FAQ|IO::Uncompress::Bunzip2::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -The primary site for the bzip2 program is F<http://www.bzip.org>. - -See the module L<Compress::Bzip2|Compress::Bzip2> - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2008 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/IO-Compress/lib/IO/Uncompress/Gunzip.pm b/ext/IO-Compress/lib/IO/Uncompress/Gunzip.pm deleted file mode 100644 index 8922865d43..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/Gunzip.pm +++ /dev/null @@ -1,1070 +0,0 @@ - -package IO::Uncompress::Gunzip ; - -require 5.004 ; - -# for RFC1952 - -use strict ; -use warnings; -use bytes; - -use IO::Uncompress::RawInflate 2.021 ; - -use Compress::Raw::Zlib 2.021 qw( crc32 ) ; -use IO::Compress::Base::Common 2.021 qw(:Status createSelfTiedObject); -use IO::Compress::Gzip::Constants 2.021 ; -use IO::Compress::Zlib::Extra 2.021 ; - -require Exporter ; - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GunzipError); - -@ISA = qw( Exporter IO::Uncompress::RawInflate ); -@EXPORT_OK = qw( $GunzipError gunzip ); -%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ; -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; -Exporter::export_ok_tags('all'); - -$GunzipError = ''; - -$VERSION = '2.021'; - -sub new -{ - my $class = shift ; - $GunzipError = ''; - my $obj = createSelfTiedObject($class, \$GunzipError); - - $obj->_create(undef, 0, @_); -} - -sub gunzip -{ - my $obj = createSelfTiedObject(undef, \$GunzipError); - return $obj->_inf(@_) ; -} - -sub getExtraParams -{ - use IO::Compress::Base::Common 2.021 qw(:Parse); - return ( 'ParseExtra' => [1, 1, Parse_boolean, 0] ) ; -} - -sub ckParams -{ - my $self = shift ; - my $got = shift ; - - # gunzip always needs crc32 - $got->value('CRC32' => 1); - - return 1; -} - -sub ckMagic -{ - my $self = shift; - - my $magic ; - $self->smartReadExact(\$magic, GZIP_ID_SIZE); - - *$self->{HeaderPending} = $magic ; - - return $self->HeaderError("Minimum header size is " . - GZIP_MIN_HEADER_SIZE . " bytes") - if length $magic != GZIP_ID_SIZE ; - - return $self->HeaderError("Bad Magic") - if ! isGzipMagic($magic) ; - - *$self->{Type} = 'rfc1952'; - - return $magic ; -} - -sub readHeader -{ - my $self = shift; - my $magic = shift; - - return $self->_readGzipHeader($magic); -} - -sub chkTrailer -{ - my $self = shift; - my $trailer = shift; - - # Check CRC & ISIZE - my ($CRC32, $ISIZE) = unpack("V V", $trailer) ; - *$self->{Info}{CRC32} = $CRC32; - *$self->{Info}{ISIZE} = $ISIZE; - - if (*$self->{Strict}) { - return $self->TrailerError("CRC mismatch") - if $CRC32 != *$self->{Uncomp}->crc32() ; - - my $exp_isize = *$self->{UnCompSize}->get32bit(); - return $self->TrailerError("ISIZE mismatch. Got $ISIZE" - . ", expected $exp_isize") - if $ISIZE != $exp_isize ; - } - - return STATUS_OK; -} - -sub isGzipMagic -{ - my $buffer = shift ; - return 0 if length $buffer < GZIP_ID_SIZE ; - my ($id1, $id2) = unpack("C C", $buffer) ; - return $id1 == GZIP_ID1 && $id2 == GZIP_ID2 ; -} - -sub _readFullGzipHeader($) -{ - my ($self) = @_ ; - my $magic = '' ; - - $self->smartReadExact(\$magic, GZIP_ID_SIZE); - - *$self->{HeaderPending} = $magic ; - - return $self->HeaderError("Minimum header size is " . - GZIP_MIN_HEADER_SIZE . " bytes") - if length $magic != GZIP_ID_SIZE ; - - - return $self->HeaderError("Bad Magic") - if ! isGzipMagic($magic) ; - - my $status = $self->_readGzipHeader($magic); - delete *$self->{Transparent} if ! defined $status ; - return $status ; -} - -sub _readGzipHeader($) -{ - my ($self, $magic) = @_ ; - my ($HeaderCRC) ; - my ($buffer) = '' ; - - $self->smartReadExact(\$buffer, GZIP_MIN_HEADER_SIZE - GZIP_ID_SIZE) - or return $self->HeaderError("Minimum header size is " . - GZIP_MIN_HEADER_SIZE . " bytes") ; - - my $keep = $magic . $buffer ; - *$self->{HeaderPending} = $keep ; - - # now split out the various parts - my ($cm, $flag, $mtime, $xfl, $os) = unpack("C C V C C", $buffer) ; - - $cm == GZIP_CM_DEFLATED - or return $self->HeaderError("Not Deflate (CM is $cm)") ; - - # check for use of reserved bits - return $self->HeaderError("Use of Reserved Bits in FLG field.") - if $flag & GZIP_FLG_RESERVED ; - - my $EXTRA ; - my @EXTRA = () ; - if ($flag & GZIP_FLG_FEXTRA) { - $EXTRA = "" ; - $self->smartReadExact(\$buffer, GZIP_FEXTRA_HEADER_SIZE) - or return $self->TruncatedHeader("FEXTRA Length") ; - - my ($XLEN) = unpack("v", $buffer) ; - $self->smartReadExact(\$EXTRA, $XLEN) - or return $self->TruncatedHeader("FEXTRA Body"); - $keep .= $buffer . $EXTRA ; - - if ($XLEN && *$self->{'ParseExtra'}) { - my $bad = IO::Compress::Zlib::Extra::parseRawExtra($EXTRA, - \@EXTRA, 1, 1); - return $self->HeaderError($bad) - if defined $bad; - } - } - - my $origname ; - if ($flag & GZIP_FLG_FNAME) { - $origname = "" ; - while (1) { - $self->smartReadExact(\$buffer, 1) - or return $self->TruncatedHeader("FNAME"); - last if $buffer eq GZIP_NULL_BYTE ; - $origname .= $buffer - } - $keep .= $origname . GZIP_NULL_BYTE ; - - return $self->HeaderError("Non ISO 8859-1 Character found in Name") - if *$self->{Strict} && $origname =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; - } - - my $comment ; - if ($flag & GZIP_FLG_FCOMMENT) { - $comment = ""; - while (1) { - $self->smartReadExact(\$buffer, 1) - or return $self->TruncatedHeader("FCOMMENT"); - last if $buffer eq GZIP_NULL_BYTE ; - $comment .= $buffer - } - $keep .= $comment . GZIP_NULL_BYTE ; - - return $self->HeaderError("Non ISO 8859-1 Character found in Comment") - if *$self->{Strict} && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o ; - } - - if ($flag & GZIP_FLG_FHCRC) { - $self->smartReadExact(\$buffer, GZIP_FHCRC_SIZE) - or return $self->TruncatedHeader("FHCRC"); - - $HeaderCRC = unpack("v", $buffer) ; - my $crc16 = crc32($keep) & 0xFF ; - - return $self->HeaderError("CRC16 mismatch.") - if *$self->{Strict} && $crc16 != $HeaderCRC; - - $keep .= $buffer ; - } - - # Assume compression method is deflated for xfl tests - #if ($xfl) { - #} - - *$self->{Type} = 'rfc1952'; - - return { - 'Type' => 'rfc1952', - 'FingerprintLength' => 2, - 'HeaderLength' => length $keep, - 'TrailerLength' => GZIP_TRAILER_SIZE, - 'Header' => $keep, - 'isMinimalHeader' => $keep eq GZIP_MINIMUM_HEADER ? 1 : 0, - - 'MethodID' => $cm, - 'MethodName' => $cm == GZIP_CM_DEFLATED ? "Deflated" : "Unknown" , - 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0, - 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0, - 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0, - 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0, - 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0, - 'Name' => $origname, - 'Comment' => $comment, - 'Time' => $mtime, - 'OsID' => $os, - 'OsName' => defined $GZIP_OS_Names{$os} - ? $GZIP_OS_Names{$os} : "Unknown", - 'HeaderCRC' => $HeaderCRC, - 'Flags' => $flag, - 'ExtraFlags' => $xfl, - 'ExtraFieldRaw' => $EXTRA, - 'ExtraField' => [ @EXTRA ], - - - #'CompSize'=> $compsize, - #'CRC32'=> $CRC32, - #'OrigSize'=> $ISIZE, - } -} - - -1; - -__END__ - - -=head1 NAME - -IO::Uncompress::Gunzip - Read RFC 1952 files/buffers - -=head1 SYNOPSIS - - use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; - - my $status = gunzip $input => $output [,OPTS] - or die "gunzip failed: $GunzipError\n"; - - my $z = new IO::Uncompress::Gunzip $input [OPTS] - or die "gunzip failed: $GunzipError\n"; - - $status = $z->read($buffer) - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - $line = $z->getline() - $char = $z->getc() - $char = $z->ungetc() - $char = $z->opened() - - $status = $z->inflateSync() - - $data = $z->trailingData() - $status = $z->nextStream() - $data = $z->getHeaderInfo() - $z->tell() - $z->seek($position, $whence) - $z->binmode() - $z->fileno() - $z->eof() - $z->close() - - $GunzipError ; - - # IO::File mode - - <$z> - read($z, $buffer); - read($z, $buffer, $length); - read($z, $buffer, $length, $offset); - tell($z) - seek($z, $position, $whence) - binmode($z) - fileno($z) - eof($z) - close($z) - -=head1 DESCRIPTION - -This module provides a Perl interface that allows the reading of -files/buffers that conform to RFC 1952. - -For writing RFC 1952 files/buffers, see the companion module IO::Compress::Gzip. - -=head1 Functional Interface - -A top-level function, C<gunzip>, is provided to carry out -"one-shot" uncompression between buffers and/or files. For finer -control over the uncompression process, see the L</"OO Interface"> -section. - - use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; - - gunzip $input => $output [,OPTS] - or die "gunzip failed: $GunzipError\n"; - -The functional interface needs Perl5.005 or better. - -=head2 gunzip $input => $output [, OPTS] - -C<gunzip> expects at least two parameters, C<$input> and C<$output>. - -=head3 The C<$input> parameter - -The parameter, C<$input>, is used to define the source of -the compressed data. - -It can take one of the following forms: - -=over 5 - -=item A filename - -If the C<$input> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for reading and the input data -will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the input data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the input data will be read -from C<$$input>. - -=item An array reference - -If C<$input> is an array reference, 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<gunzip> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -uncompressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the uncompressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the uncompressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the uncompressed data will be -stored in C<$$output>. - -=item An Array Reference - -If C<$output> is an array reference, the uncompressed data will be -pushed onto the array. - -=item An Output FileGlob - -If C<$output> is a string that is delimited by the characters "<" and ">" -C<gunzip> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple compressed files/buffers and C<$output> is -a single file/buffer, after uncompression C<$output> will contain a -concatenation of all the uncompressed data from each of the input -files/buffers. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<gunzip>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<gunzip> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<gunzip> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeOut => 0|1 >> - -When writing to a file or filehandle, set C<binmode> before writing to the -file. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=item C<< MultiStream => 0|1 >> - -If the input file/buffer contains multiple compressed data streams, this -option will uncompress the whole lot as a single data stream. - -Defaults to 0. - -=item C<< TrailingData => $scalar >> - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option. - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt.gz> and write the -uncompressed data to the file C<file1.txt>. - - use strict ; - use warnings ; - use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; - - my $input = "file1.txt.gz"; - my $output = "file1.txt"; - gunzip $input => $output - or die "gunzip failed: $GunzipError\n"; - -To read from an existing Perl filehandle, C<$input>, and write the -uncompressed data to a buffer, C<$buffer>. - - use strict ; - use warnings ; - use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; - use IO::File ; - - my $input = new IO::File "<file1.txt.gz" - or die "Cannot open 'file1.txt.gz': $!\n" ; - my $buffer ; - gunzip $input => \$buffer - or die "gunzip failed: $GunzipError\n"; - -To uncompress all files in the directory "/my/home" that match "*.txt.gz" and store the compressed data in the same directory - - use strict ; - use warnings ; - use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; - - gunzip '</my/home/*.txt.gz>' => '</my/home/#1.txt>' - or die "gunzip failed: $GunzipError\n"; - -and if you want to compress each file one at a time, this will do the trick - - use strict ; - use warnings ; - use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; - - for my $input ( glob "/my/home/*.txt.gz" ) - { - my $output = $input; - $output =~ s/.gz// ; - gunzip $input => $output - or die "Error compressing '$input': $GunzipError\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for IO::Uncompress::Gunzip is shown below - - my $z = new IO::Uncompress::Gunzip $input [OPTS] - or die "IO::Uncompress::Gunzip failed: $GunzipError\n"; - -Returns an C<IO::Uncompress::Gunzip> object on success and undef on failure. -The variable C<$GunzipError> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Uncompress::Gunzip can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal input file operations can be carried out with -C<$z>. For example, to read a line from a compressed file/buffer you can -use either of these forms - - $line = $z->getline(); - $line = <$z>; - -The mandatory parameter C<$input> is used to determine the source of the -compressed data. This parameter can take one of three forms. - -=over 5 - -=item A filename - -If the C<$input> parameter is a scalar, it is assumed to be a filename. This -file will be opened for reading and the compressed data will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the compressed data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the compressed data will be read from -C<$$output>. - -=back - -=head2 Constructor Options - -The option names defined below are case insensitive and can be optionally -prefixed by a '-'. So all of the following are valid - - -AutoClose - -autoclose - AUTOCLOSE - autoclose - -OPTS is a combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$input> parameter is a filehandle. If -specified, and the value is true, it will result in the file being closed once -either the C<close> method is called or the IO::Uncompress::Gunzip object is -destroyed. - -This parameter defaults to 0. - -=item C<< MultiStream => 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 C<< Prime => $string >> - -This option will uncompress the contents of C<$string> before processing the -input file/buffer. - -This option can be useful when the compressed data is embedded in another -file/data structure and it is not possible to work out where the compressed -data begins without having to read the first few bytes. If this is the -case, the uncompression can be I<primed> with these bytes using this -option. - -=item C<< Transparent => 0|1 >> - -If this option is set and the input file/buffer is not compressed data, -the module will allow reading of it anyway. - -In addition, if the input file/buffer does contain compressed data and -there is non-compressed data immediately following it, setting this option -will make this module treat the whole file/bufffer as a single data stream. - -This option defaults to 1. - -=item C<< BlockSize => $num >> - -When reading the compressed input data, IO::Uncompress::Gunzip will read it in -blocks of C<$num> bytes. - -This option defaults to 4096. - -=item C<< InputLength => $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 C<< Append => 0|1 >> - -This option controls what the C<read> method does with uncompressed data. - -If set to 1, all uncompressed data will be appended to the output parameter -of the C<read> method. - -If set to 0, the contents of the output parameter of the C<read> method -will be overwritten by the uncompressed data. - -Defaults to 0. - -=item C<< Strict => 0|1 >> - -This option controls whether the extra checks defined below are used when -carrying out the decompression. When Strict is on, the extra tests are -carried out, when Strict is off they are not. - -The default for this option is off. - -=over 5 - -=item 1 - -If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the -header must match the crc16 value of the gzip header actually read. - -=item 2 - -If the gzip header contains a name field (FNAME) it consists solely of ISO -8859-1 characters. - -=item 3 - -If the gzip header contains a comment field (FCOMMENT) it consists solely -of ISO 8859-1 characters plus line-feed. - -=item 4 - -If the gzip FEXTRA header field is present it must conform to the sub-field -structure as defined in RFC 1952. - -=item 5 - -The CRC32 and ISIZE trailer fields must be present. - -=item 6 - -The value of the CRC32 field read must match the crc32 value of the -uncompressed data actually contained in the gzip file. - -=item 7 - -The value of the ISIZE fields read must match the length of the -uncompressed data actually read from the file. - -=back - -=item C<< ParseExtra => 0|1 >> -If the gzip FEXTRA header field is present and this option is set, it will -force the module to check that it conforms to the sub-field structure as -defined in RFC 1952. - -If the C<Strict> is on it will automatically enable this option. - -Defaults to 0. - -=back - -=head2 Examples - -TODO - -=head1 Methods - -=head2 read - -Usage is - - $status = $z->read($buffer) - -Reads a block of compressed data (the size the the compressed block is -determined by the C<Buffer> option in the constructor), uncompresses it and -writes any uncompressed data into C<$buffer>. If the C<Append> parameter is -set in the constructor, the uncompressed data will be appended to the -C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 read - -Usage is - - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - - $status = read($z, $buffer, $length) - $status = read($z, $buffer, $length, $offset) - -Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. - -The main difference between this form of the C<read> method and the -previous one, is that this one will attempt to return I<exactly> C<$length> -bytes. The only circumstances that this function will not is if end-of-file -or an IO error is encountered. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 getline - -Usage is - - $line = $z->getline() - $line = <$z> - -Reads a single line. - -This method fully supports the use of of the variable C<$/> (or -C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to -determine what constitutes an end of line. Paragraph mode, record mode and -file slurp mode are all supported. - -=head2 getc - -Usage is - - $char = $z->getc() - -Read a single character. - -=head2 ungetc - -Usage is - - $char = $z->ungetc($string) - -=head2 inflateSync - -Usage is - - $status = $z->inflateSync() - -TODO - -=head2 getHeaderInfo - -Usage is - - $hdr = $z->getHeaderInfo(); - @hdrs = $z->getHeaderInfo(); - -This method returns either a hash reference (in scalar context) or a list -or hash references (in array context) that contains information about each -of the header fields in the compressed data stream(s). - -=over 5 - -=item Name - -The contents of the Name header field, if present. If no name is -present, the value will be undef. Note this is different from a zero length -name, which will return an empty string. - -=item Comment - -The contents of the Comment header field, if present. If no comment is -present, the value will be undef. Note this is different from a zero length -comment, which will return an empty string. - -=back - -=head2 tell - -Usage is - - $z->tell() - tell $z - -Returns the uncompressed file offset. - -=head2 eof - -Usage is - - $z->eof(); - eof($z); - -Returns true if the end of the compressed input stream has been reached. - -=head2 seek - - $z->seek($position, $whence); - seek($z, $position, $whence); - -Provides a sub-set of the C<seek> functionality, with the restriction -that it is only legal to seek forward in the input file/buffer. -It is a fatal error to attempt to seek backward. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<EXPR> 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, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<undef>. - -=head2 close - - $z->close() ; - close $z ; - -Closes the output file/buffer. - -For most versions of Perl this method will be automatically invoked if -the IO::Uncompress::Gunzip object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Uncompress::Gunzip -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 nextStream - -Usage is - - my $status = $z->nextStream(); - -Skips to the next compressed data stream in the input file/buffer. If a new -compressed data stream is found, the eof marker will be cleared and C<$.> -will be reset to 0. - -Returns 1 if a new stream was found, 0 if none was found, and -1 if an -error was encountered. - -=head2 trailingData - -Usage is - - my $data = $z->trailingData(); - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. It only makes sense to call -this method once the end of the compressed data stream has been -encountered. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option in the constructor. - -=head1 Importing - -No symbolic constants are required by this IO::Uncompress::Gunzip at present. - -=over 5 - -=item :all - -Imports C<gunzip> and C<$GunzipError>. -Same as doing this - - use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; - -=back - -=head1 EXAMPLES - -=head2 Working with Net::FTP - -See L<IO::Uncompress::Gunzip::FAQ|IO::Uncompress::Gunzip::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Uncompress/Inflate.pm b/ext/IO-Compress/lib/IO/Uncompress/Inflate.pm deleted file mode 100644 index 20aecc7864..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/Inflate.pm +++ /dev/null @@ -1,941 +0,0 @@ -package IO::Uncompress::Inflate ; -# for RFC1950 - -use strict ; -use warnings; -use bytes; - -use IO::Compress::Base::Common 2.021 qw(:Status createSelfTiedObject); -use IO::Compress::Zlib::Constants 2.021 ; - -use IO::Uncompress::RawInflate 2.021 ; - -require Exporter ; -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); - -$VERSION = '2.021'; -$InflateError = ''; - -@ISA = qw( Exporter IO::Uncompress::RawInflate ); -@EXPORT_OK = qw( $InflateError inflate ) ; -%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ; -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; -Exporter::export_ok_tags('all'); - - -sub new -{ - my $class = shift ; - my $obj = createSelfTiedObject($class, \$InflateError); - - $obj->_create(undef, 0, @_); -} - -sub inflate -{ - my $obj = createSelfTiedObject(undef, \$InflateError); - return $obj->_inf(@_); -} - -sub getExtraParams -{ - return (); -} - -sub ckParams -{ - my $self = shift ; - my $got = shift ; - - # gunzip always needs adler32 - $got->value('ADLER32' => 1); - - return 1; -} - -sub ckMagic -{ - my $self = shift; - - my $magic ; - $self->smartReadExact(\$magic, ZLIB_HEADER_SIZE); - - *$self->{HeaderPending} = $magic ; - - return $self->HeaderError("Header size is " . - ZLIB_HEADER_SIZE . " bytes") - if length $magic != ZLIB_HEADER_SIZE; - - #return $self->HeaderError("CRC mismatch.") - return undef - if ! $self->isZlibMagic($magic) ; - - *$self->{Type} = 'rfc1950'; - return $magic; -} - -sub readHeader -{ - my $self = shift; - my $magic = shift ; - - return $self->_readDeflateHeader($magic) ; -} - -sub chkTrailer -{ - my $self = shift; - my $trailer = shift; - - my $ADLER32 = unpack("N", $trailer) ; - *$self->{Info}{ADLER32} = $ADLER32; - return $self->TrailerError("CRC mismatch") - if *$self->{Strict} && $ADLER32 != *$self->{Uncomp}->adler32() ; - - return STATUS_OK; -} - - - -sub isZlibMagic -{ - my $self = shift; - my $buffer = shift ; - - return 0 - if length $buffer < ZLIB_HEADER_SIZE ; - - my $hdr = unpack("n", $buffer) ; - #return 0 if $hdr % 31 != 0 ; - return $self->HeaderError("CRC mismatch.") - if $hdr % 31 != 0 ; - - my ($CMF, $FLG) = unpack "C C", $buffer; - my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ; - - # Only Deflate supported - return $self->HeaderError("Not Deflate (CM is $cm)") - if $cm != ZLIB_CMF_CM_DEFLATED ; - - # Max window value is 7 for Deflate. - my $cinfo = bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS) ; - return $self->HeaderError("CINFO > " . ZLIB_CMF_CINFO_MAX . - " (CINFO is $cinfo)") - if $cinfo > ZLIB_CMF_CINFO_MAX ; - - return 1; -} - -sub bits -{ - my $data = shift ; - my $offset = shift ; - my $mask = shift ; - - ($data >> $offset ) & $mask & 0xFF ; -} - - -sub _readDeflateHeader -{ - my ($self, $buffer) = @_ ; - -# if (! $buffer) { -# $self->smartReadExact(\$buffer, ZLIB_HEADER_SIZE); -# -# *$self->{HeaderPending} = $buffer ; -# -# return $self->HeaderError("Header size is " . -# ZLIB_HEADER_SIZE . " bytes") -# if length $buffer != ZLIB_HEADER_SIZE; -# -# return $self->HeaderError("CRC mismatch.") -# if ! isZlibMagic($buffer) ; -# } - - my ($CMF, $FLG) = unpack "C C", $buffer; - my $FDICT = bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ), - - my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ; - $cm == ZLIB_CMF_CM_DEFLATED - or return $self->HeaderError("Not Deflate (CM is $cm)") ; - - my $DICTID; - if ($FDICT) { - $self->smartReadExact(\$buffer, ZLIB_FDICT_SIZE) - or return $self->TruncatedHeader("FDICT"); - - $DICTID = unpack("N", $buffer) ; - } - - *$self->{Type} = 'rfc1950'; - - return { - 'Type' => 'rfc1950', - 'FingerprintLength' => ZLIB_HEADER_SIZE, - 'HeaderLength' => ZLIB_HEADER_SIZE, - 'TrailerLength' => ZLIB_TRAILER_SIZE, - 'Header' => $buffer, - - CMF => $CMF , - CM => bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS ), - CINFO => bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS ), - FLG => $FLG , - FCHECK => bits($FLG, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS), - FDICT => bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ), - FLEVEL => bits($FLG, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS ), - DICTID => $DICTID , - - }; -} - - - - -1 ; - -__END__ - - -=head1 NAME - -IO::Uncompress::Inflate - Read RFC 1950 files/buffers - -=head1 SYNOPSIS - - use IO::Uncompress::Inflate qw(inflate $InflateError) ; - - my $status = inflate $input => $output [,OPTS] - or die "inflate failed: $InflateError\n"; - - my $z = new IO::Uncompress::Inflate $input [OPTS] - or die "inflate failed: $InflateError\n"; - - $status = $z->read($buffer) - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - $line = $z->getline() - $char = $z->getc() - $char = $z->ungetc() - $char = $z->opened() - - $status = $z->inflateSync() - - $data = $z->trailingData() - $status = $z->nextStream() - $data = $z->getHeaderInfo() - $z->tell() - $z->seek($position, $whence) - $z->binmode() - $z->fileno() - $z->eof() - $z->close() - - $InflateError ; - - # IO::File mode - - <$z> - read($z, $buffer); - read($z, $buffer, $length); - read($z, $buffer, $length, $offset); - tell($z) - seek($z, $position, $whence) - binmode($z) - fileno($z) - eof($z) - close($z) - -=head1 DESCRIPTION - -This module provides a Perl interface that allows the reading of -files/buffers that conform to RFC 1950. - -For writing RFC 1950 files/buffers, see the companion module IO::Compress::Deflate. - -=head1 Functional Interface - -A top-level function, C<inflate>, is provided to carry out -"one-shot" uncompression between buffers and/or files. For finer -control over the uncompression process, see the L</"OO Interface"> -section. - - use IO::Uncompress::Inflate qw(inflate $InflateError) ; - - inflate $input => $output [,OPTS] - or die "inflate failed: $InflateError\n"; - -The functional interface needs Perl5.005 or better. - -=head2 inflate $input => $output [, OPTS] - -C<inflate> expects at least two parameters, C<$input> and C<$output>. - -=head3 The C<$input> parameter - -The parameter, C<$input>, is used to define the source of -the compressed data. - -It can take one of the following forms: - -=over 5 - -=item A filename - -If the C<$input> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for reading and the input data -will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the input data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the input data will be read -from C<$$input>. - -=item An array reference - -If C<$input> is an array reference, 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<inflate> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -uncompressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the uncompressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the uncompressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the uncompressed data will be -stored in C<$$output>. - -=item An Array Reference - -If C<$output> is an array reference, the uncompressed data will be -pushed onto the array. - -=item An Output FileGlob - -If C<$output> is a string that is delimited by the characters "<" and ">" -C<inflate> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple compressed files/buffers and C<$output> is -a single file/buffer, after uncompression C<$output> will contain a -concatenation of all the uncompressed data from each of the input -files/buffers. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<inflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<inflate> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<inflate> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeOut => 0|1 >> - -When writing to a file or filehandle, set C<binmode> before writing to the -file. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=item C<< MultiStream => 0|1 >> - -If the input file/buffer contains multiple compressed data streams, this -option will uncompress the whole lot as a single data stream. - -Defaults to 0. - -=item C<< TrailingData => $scalar >> - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option. - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt.1950> and write the -uncompressed data to the file C<file1.txt>. - - use strict ; - use warnings ; - use IO::Uncompress::Inflate qw(inflate $InflateError) ; - - my $input = "file1.txt.1950"; - my $output = "file1.txt"; - inflate $input => $output - or die "inflate failed: $InflateError\n"; - -To read from an existing Perl filehandle, C<$input>, and write the -uncompressed data to a buffer, C<$buffer>. - - use strict ; - use warnings ; - use IO::Uncompress::Inflate qw(inflate $InflateError) ; - use IO::File ; - - my $input = new IO::File "<file1.txt.1950" - or die "Cannot open 'file1.txt.1950': $!\n" ; - my $buffer ; - inflate $input => \$buffer - or die "inflate failed: $InflateError\n"; - -To uncompress all files in the directory "/my/home" that match "*.txt.1950" and store the compressed data in the same directory - - use strict ; - use warnings ; - use IO::Uncompress::Inflate qw(inflate $InflateError) ; - - inflate '</my/home/*.txt.1950>' => '</my/home/#1.txt>' - or die "inflate failed: $InflateError\n"; - -and if you want to compress each file one at a time, this will do the trick - - use strict ; - use warnings ; - use IO::Uncompress::Inflate qw(inflate $InflateError) ; - - for my $input ( glob "/my/home/*.txt.1950" ) - { - my $output = $input; - $output =~ s/.1950// ; - inflate $input => $output - or die "Error compressing '$input': $InflateError\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for IO::Uncompress::Inflate is shown below - - my $z = new IO::Uncompress::Inflate $input [OPTS] - or die "IO::Uncompress::Inflate failed: $InflateError\n"; - -Returns an C<IO::Uncompress::Inflate> object on success and undef on failure. -The variable C<$InflateError> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Uncompress::Inflate can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal input file operations can be carried out with -C<$z>. For example, to read a line from a compressed file/buffer you can -use either of these forms - - $line = $z->getline(); - $line = <$z>; - -The mandatory parameter C<$input> is used to determine the source of the -compressed data. This parameter can take one of three forms. - -=over 5 - -=item A filename - -If the C<$input> parameter is a scalar, it is assumed to be a filename. This -file will be opened for reading and the compressed data will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the compressed data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the compressed data will be read from -C<$$output>. - -=back - -=head2 Constructor Options - -The option names defined below are case insensitive and can be optionally -prefixed by a '-'. So all of the following are valid - - -AutoClose - -autoclose - AUTOCLOSE - autoclose - -OPTS is a combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$input> parameter is a filehandle. If -specified, and the value is true, it will result in the file being closed once -either the C<close> method is called or the IO::Uncompress::Inflate object is -destroyed. - -This parameter defaults to 0. - -=item C<< MultiStream => 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 C<< Prime => $string >> - -This option will uncompress the contents of C<$string> before processing the -input file/buffer. - -This option can be useful when the compressed data is embedded in another -file/data structure and it is not possible to work out where the compressed -data begins without having to read the first few bytes. If this is the -case, the uncompression can be I<primed> with these bytes using this -option. - -=item C<< Transparent => 0|1 >> - -If this option is set and the input file/buffer is not compressed data, -the module will allow reading of it anyway. - -In addition, if the input file/buffer does contain compressed data and -there is non-compressed data immediately following it, setting this option -will make this module treat the whole file/bufffer as a single data stream. - -This option defaults to 1. - -=item C<< BlockSize => $num >> - -When reading the compressed input data, IO::Uncompress::Inflate will read it in -blocks of C<$num> bytes. - -This option defaults to 4096. - -=item C<< InputLength => $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 C<< Append => 0|1 >> - -This option controls what the C<read> method does with uncompressed data. - -If set to 1, all uncompressed data will be appended to the output parameter -of the C<read> method. - -If set to 0, the contents of the output parameter of the C<read> method -will be overwritten by the uncompressed data. - -Defaults to 0. - -=item C<< Strict => 0|1 >> - -This option controls whether the extra checks defined below are used when -carrying out the decompression. When Strict is on, the extra tests are -carried out, when Strict is off they are not. - -The default for this option is off. - -=over 5 - -=item 1 - -The ADLER32 checksum field must be present. - -=item 2 - -The value of the ADLER32 field read must match the adler32 value of the -uncompressed data actually contained in the file. - -=back - -=back - -=head2 Examples - -TODO - -=head1 Methods - -=head2 read - -Usage is - - $status = $z->read($buffer) - -Reads a block of compressed data (the size the the compressed block is -determined by the C<Buffer> option in the constructor), uncompresses it and -writes any uncompressed data into C<$buffer>. If the C<Append> parameter is -set in the constructor, the uncompressed data will be appended to the -C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 read - -Usage is - - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - - $status = read($z, $buffer, $length) - $status = read($z, $buffer, $length, $offset) - -Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. - -The main difference between this form of the C<read> method and the -previous one, is that this one will attempt to return I<exactly> C<$length> -bytes. The only circumstances that this function will not is if end-of-file -or an IO error is encountered. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 getline - -Usage is - - $line = $z->getline() - $line = <$z> - -Reads a single line. - -This method fully supports the use of of the variable C<$/> (or -C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to -determine what constitutes an end of line. Paragraph mode, record mode and -file slurp mode are all supported. - -=head2 getc - -Usage is - - $char = $z->getc() - -Read a single character. - -=head2 ungetc - -Usage is - - $char = $z->ungetc($string) - -=head2 inflateSync - -Usage is - - $status = $z->inflateSync() - -TODO - -=head2 getHeaderInfo - -Usage is - - $hdr = $z->getHeaderInfo(); - @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<seek> functionality, with the restriction -that it is only legal to seek forward in the input file/buffer. -It is a fatal error to attempt to seek backward. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<EXPR> 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, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<undef>. - -=head2 close - - $z->close() ; - close $z ; - -Closes the output file/buffer. - -For most versions of Perl this method will be automatically invoked if -the IO::Uncompress::Inflate object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Uncompress::Inflate -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 nextStream - -Usage is - - my $status = $z->nextStream(); - -Skips to the next compressed data stream in the input file/buffer. If a new -compressed data stream is found, the eof marker will be cleared and C<$.> -will be reset to 0. - -Returns 1 if a new stream was found, 0 if none was found, and -1 if an -error was encountered. - -=head2 trailingData - -Usage is - - my $data = $z->trailingData(); - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. It only makes sense to call -this method once the end of the compressed data stream has been -encountered. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option in the constructor. - -=head1 Importing - -No symbolic constants are required by this IO::Uncompress::Inflate at present. - -=over 5 - -=item :all - -Imports C<inflate> and C<$InflateError>. -Same as doing this - - use IO::Uncompress::Inflate qw(inflate $InflateError) ; - -=back - -=head1 EXAMPLES - -=head2 Working with Net::FTP - -See L<IO::Uncompress::Inflate::FAQ|IO::Uncompress::Inflate::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Uncompress/RawInflate.pm b/ext/IO-Compress/lib/IO/Uncompress/RawInflate.pm deleted file mode 100644 index 5727192e7c..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/RawInflate.pm +++ /dev/null @@ -1,1069 +0,0 @@ -package IO::Uncompress::RawInflate ; -# for RFC1951 - -use strict ; -use warnings; -use bytes; - -use Compress::Raw::Zlib 2.021 ; -use IO::Compress::Base::Common 2.021 qw(:Status createSelfTiedObject); - -use IO::Uncompress::Base 2.021 ; -use IO::Uncompress::Adapter::Inflate 2.021 ; - -require Exporter ; -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError); - -$VERSION = '2.021'; -$RawInflateError = ''; - -@ISA = qw( Exporter IO::Uncompress::Base ); -@EXPORT_OK = qw( $RawInflateError rawinflate ) ; -%DEFLATE_CONSTANTS = (); -%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ; -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; -Exporter::export_ok_tags('all'); - -#{ -# # Execute at runtime -# my %bad; -# for my $module (qw(Compress::Raw::Zlib IO::Compress::Base::Common IO::Uncompress::Base IO::Uncompress::Adapter::Inflate)) -# { -# my $ver = ${ $module . "::VERSION"} ; -# -# $bad{$module} = $ver -# if $ver ne $VERSION; -# } -# -# if (keys %bad) -# { -# my $string = join "\n", map { "$_ $bad{$_}" } keys %bad; -# die caller(0)[0] . "needs version $VERSION mismatch\n$string\n"; -# } -#} - -sub new -{ - my $class = shift ; - my $obj = createSelfTiedObject($class, \$RawInflateError); - $obj->_create(undef, 0, @_); -} - -sub rawinflate -{ - my $obj = createSelfTiedObject(undef, \$RawInflateError); - return $obj->_inf(@_); -} - -sub getExtraParams -{ - return (); -} - -sub ckParams -{ - my $self = shift ; - my $got = shift ; - - return 1; -} - -sub mkUncomp -{ - my $self = shift ; - my $got = shift ; - - my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject( - $got->value('CRC32'), - $got->value('ADLER32'), - $got->value('Scan'), - ); - - return $self->saveErrorString(undef, $errstr, $errno) - if ! defined $obj; - - *$self->{Uncomp} = $obj; - - my $magic = $self->ckMagic() - or return 0; - - *$self->{Info} = $self->readHeader($magic) - or return undef ; - - return 1; - -} - - -sub ckMagic -{ - my $self = shift; - - return $self->_isRaw() ; -} - -sub readHeader -{ - my $self = shift; - my $magic = shift ; - - return { - 'Type' => 'rfc1951', - 'FingerprintLength' => 0, - 'HeaderLength' => 0, - 'TrailerLength' => 0, - 'Header' => '' - }; -} - -sub chkTrailer -{ - return STATUS_OK ; -} - -sub _isRaw -{ - my $self = shift ; - - my $got = $self->_isRawx(@_); - - if ($got) { - *$self->{Pending} = *$self->{HeaderPending} ; - } - else { - $self->pushBack(*$self->{HeaderPending}); - *$self->{Uncomp}->reset(); - } - *$self->{HeaderPending} = ''; - - return $got ; -} - -sub _isRawx -{ - my $self = shift ; - my $magic = shift ; - - $magic = '' unless defined $magic ; - - my $buffer = ''; - - $self->smartRead(\$buffer, *$self->{BlockSize}) >= 0 - or return $self->saveErrorString(undef, "No data to read"); - - my $temp_buf = $magic . $buffer ; - *$self->{HeaderPending} = $temp_buf ; - $buffer = ''; - my $status = *$self->{Uncomp}->uncompr(\$temp_buf, \$buffer, $self->smartEof()) ; - - return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, STATUS_ERROR) - if $status == STATUS_ERROR; - - $self->pushBack($temp_buf) ; - - return $self->saveErrorString(undef, "unexpected end of file", STATUS_ERROR) - if $self->smartEof() && $status != STATUS_ENDSTREAM; - - #my $buf_len = *$self->{Uncomp}->uncompressedBytes(); - my $buf_len = length $buffer; - - if ($status == STATUS_ENDSTREAM) { - if (*$self->{MultiStream} - && (length $temp_buf || ! $self->smartEof())){ - *$self->{NewStream} = 1 ; - *$self->{EndStream} = 0 ; - } - else { - *$self->{EndStream} = 1 ; - } - } - *$self->{HeaderPending} = $buffer ; - *$self->{InflatedBytesRead} = $buf_len ; - *$self->{TotalInflatedBytesRead} += $buf_len ; - *$self->{Type} = 'rfc1951'; - - $self->saveStatus(STATUS_OK); - - return { - 'Type' => 'rfc1951', - 'HeaderLength' => 0, - 'TrailerLength' => 0, - 'Header' => '' - }; -} - - -sub inflateSync -{ - my $self = shift ; - - # inflateSync is a no-op in Plain mode - return 1 - if *$self->{Plain} ; - - return 0 if *$self->{Closed} ; - #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; - return 0 if ! length *$self->{Pending} && *$self->{EndStream} ; - - # Disable CRC check - *$self->{Strict} = 0 ; - - my $status ; - while (1) - { - my $temp_buf ; - - if (length *$self->{Pending} ) - { - $temp_buf = *$self->{Pending} ; - *$self->{Pending} = ''; - } - else - { - $status = $self->smartRead(\$temp_buf, *$self->{BlockSize}) ; - return $self->saveErrorString(0, "Error Reading Data") - if $status < 0 ; - - if ($status == 0 ) { - *$self->{EndStream} = 1 ; - return $self->saveErrorString(0, "unexpected end of file", STATUS_ERROR); - } - } - - $status = *$self->{Uncomp}->sync($temp_buf) ; - - if ($status == STATUS_OK) - { - *$self->{Pending} .= $temp_buf ; - return 1 ; - } - - last unless $status == STATUS_ERROR ; - } - - return 0; -} - -#sub performScan -#{ -# my $self = shift ; -# -# my $status ; -# my $end_offset = 0; -# -# $status = $self->scan() -# #or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $self->errorNo) ; -# or return $self->saveErrorString(G_ERR, "Error Scanning: $status") -# -# $status = $self->zap($end_offset) -# or return $self->saveErrorString(G_ERR, "Error Zapping: $status"); -# #or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $self->errorNo) ; -# -# #(*$obj->{Deflate}, $status) = $inf->createDeflate(); -# -## *$obj->{Header} = *$inf->{Info}{Header}; -## *$obj->{UnCompSize_32bit} = -## *$obj->{BytesWritten} = *$inf->{UnCompSize_32bit} ; -## *$obj->{CompSize_32bit} = *$inf->{CompSize_32bit} ; -# -# -## if ( $outType eq 'buffer') -## { substr( ${ *$self->{Buffer} }, $end_offset) = '' } -## elsif ($outType eq 'handle' || $outType eq 'filename') { -## *$self->{FH} = *$inf->{FH} ; -## delete *$inf->{FH}; -## *$obj->{FH}->flush() ; -## *$obj->{Handle} = 1 if $outType eq 'handle'; -## -## #seek(*$obj->{FH}, $end_offset, SEEK_SET) -## *$obj->{FH}->seek($end_offset, SEEK_SET) -## or return $obj->saveErrorString(undef, $!, $!) ; -## } -# -#} - -sub scan -{ - my $self = shift ; - - return 1 if *$self->{Closed} ; - return 1 if !length *$self->{Pending} && *$self->{EndStream} ; - - my $buffer = '' ; - my $len = 0; - - $len = $self->_raw_read(\$buffer, 1) - while ! *$self->{EndStream} && $len >= 0 ; - - #return $len if $len < 0 ? $len : 0 ; - return $len < 0 ? 0 : 1 ; -} - -sub zap -{ - my $self = shift ; - - my $headerLength = *$self->{Info}{HeaderLength}; - my $block_offset = $headerLength + *$self->{Uncomp}->getLastBlockOffset(); - $_[0] = $headerLength + *$self->{Uncomp}->getEndOffset(); - #printf "# End $_[0], headerlen $headerLength \n";; - #printf "# block_offset $block_offset %x\n", $block_offset; - my $byte ; - ( $self->smartSeek($block_offset) && - $self->smartRead(\$byte, 1) ) - or return $self->saveErrorString(0, $!, $!); - - #printf "#byte is %x\n", unpack('C*',$byte); - *$self->{Uncomp}->resetLastBlockByte($byte); - #printf "#to byte is %x\n", unpack('C*',$byte); - - ( $self->smartSeek($block_offset) && - $self->smartWrite($byte) ) - or return $self->saveErrorString(0, $!, $!); - - #$self->smartSeek($end_offset, 1); - - return 1 ; -} - -sub createDeflate -{ - my $self = shift ; - my ($def, $status) = *$self->{Uncomp}->createDeflateStream( - -AppendOutput => 1, - -WindowBits => - MAX_WBITS, - -CRC32 => *$self->{Params}->value('CRC32'), - -ADLER32 => *$self->{Params}->value('ADLER32'), - ); - - return wantarray ? ($status, $def) : $def ; -} - - -1; - -__END__ - - -=head1 NAME - -IO::Uncompress::RawInflate - Read RFC 1951 files/buffers - -=head1 SYNOPSIS - - use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; - - my $status = rawinflate $input => $output [,OPTS] - or die "rawinflate failed: $RawInflateError\n"; - - my $z = new IO::Uncompress::RawInflate $input [OPTS] - or die "rawinflate failed: $RawInflateError\n"; - - $status = $z->read($buffer) - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - $line = $z->getline() - $char = $z->getc() - $char = $z->ungetc() - $char = $z->opened() - - $status = $z->inflateSync() - - $data = $z->trailingData() - $status = $z->nextStream() - $data = $z->getHeaderInfo() - $z->tell() - $z->seek($position, $whence) - $z->binmode() - $z->fileno() - $z->eof() - $z->close() - - $RawInflateError ; - - # IO::File mode - - <$z> - read($z, $buffer); - read($z, $buffer, $length); - read($z, $buffer, $length, $offset); - tell($z) - seek($z, $position, $whence) - binmode($z) - fileno($z) - eof($z) - close($z) - -=head1 DESCRIPTION - -This module provides a Perl interface that allows the reading of -files/buffers that conform to RFC 1951. - -For writing RFC 1951 files/buffers, see the companion module IO::Compress::RawDeflate. - -=head1 Functional Interface - -A top-level function, C<rawinflate>, is provided to carry out -"one-shot" uncompression between buffers and/or files. For finer -control over the uncompression process, see the L</"OO Interface"> -section. - - use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; - - rawinflate $input => $output [,OPTS] - or die "rawinflate failed: $RawInflateError\n"; - -The functional interface needs Perl5.005 or better. - -=head2 rawinflate $input => $output [, OPTS] - -C<rawinflate> expects at least two parameters, C<$input> and C<$output>. - -=head3 The C<$input> parameter - -The parameter, C<$input>, is used to define the source of -the compressed data. - -It can take one of the following forms: - -=over 5 - -=item A filename - -If the C<$input> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for reading and the input data -will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the input data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the input data will be read -from C<$$input>. - -=item An array reference - -If C<$input> is an array reference, 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<rawinflate> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -uncompressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the uncompressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the uncompressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the uncompressed data will be -stored in C<$$output>. - -=item An Array Reference - -If C<$output> is an array reference, the uncompressed data will be -pushed onto the array. - -=item An Output FileGlob - -If C<$output> is a string that is delimited by the characters "<" and ">" -C<rawinflate> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple compressed files/buffers and C<$output> is -a single file/buffer, after uncompression C<$output> will contain a -concatenation of all the uncompressed data from each of the input -files/buffers. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<rawinflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<rawinflate> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<rawinflate> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeOut => 0|1 >> - -When writing to a file or filehandle, set C<binmode> before writing to the -file. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=item C<< MultiStream => 0|1 >> - -This option is a no-op. - -=item C<< TrailingData => $scalar >> - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option. - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt.1951> and write the -uncompressed data to the file C<file1.txt>. - - use strict ; - use warnings ; - use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; - - my $input = "file1.txt.1951"; - my $output = "file1.txt"; - rawinflate $input => $output - or die "rawinflate failed: $RawInflateError\n"; - -To read from an existing Perl filehandle, C<$input>, and write the -uncompressed data to a buffer, C<$buffer>. - - use strict ; - use warnings ; - use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; - use IO::File ; - - my $input = new IO::File "<file1.txt.1951" - or die "Cannot open 'file1.txt.1951': $!\n" ; - my $buffer ; - rawinflate $input => \$buffer - or die "rawinflate failed: $RawInflateError\n"; - -To uncompress all files in the directory "/my/home" that match "*.txt.1951" and store the compressed data in the same directory - - use strict ; - use warnings ; - use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; - - rawinflate '</my/home/*.txt.1951>' => '</my/home/#1.txt>' - or die "rawinflate failed: $RawInflateError\n"; - -and if you want to compress each file one at a time, this will do the trick - - use strict ; - use warnings ; - use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; - - for my $input ( glob "/my/home/*.txt.1951" ) - { - my $output = $input; - $output =~ s/.1951// ; - rawinflate $input => $output - or die "Error compressing '$input': $RawInflateError\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for IO::Uncompress::RawInflate is shown below - - my $z = new IO::Uncompress::RawInflate $input [OPTS] - or die "IO::Uncompress::RawInflate failed: $RawInflateError\n"; - -Returns an C<IO::Uncompress::RawInflate> object on success and undef on failure. -The variable C<$RawInflateError> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Uncompress::RawInflate can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal input file operations can be carried out with -C<$z>. For example, to read a line from a compressed file/buffer you can -use either of these forms - - $line = $z->getline(); - $line = <$z>; - -The mandatory parameter C<$input> is used to determine the source of the -compressed data. This parameter can take one of three forms. - -=over 5 - -=item A filename - -If the C<$input> parameter is a scalar, it is assumed to be a filename. This -file will be opened for reading and the compressed data will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the compressed data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the compressed data will be read from -C<$$output>. - -=back - -=head2 Constructor Options - -The option names defined below are case insensitive and can be optionally -prefixed by a '-'. So all of the following are valid - - -AutoClose - -autoclose - AUTOCLOSE - autoclose - -OPTS is a combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$input> parameter is a filehandle. If -specified, and the value is true, it will result in the file being closed once -either the C<close> method is called or the IO::Uncompress::RawInflate object is -destroyed. - -This parameter defaults to 0. - -=item C<< MultiStream => 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 C<< Prime => $string >> - -This option will uncompress the contents of C<$string> before processing the -input file/buffer. - -This option can be useful when the compressed data is embedded in another -file/data structure and it is not possible to work out where the compressed -data begins without having to read the first few bytes. If this is the -case, the uncompression can be I<primed> with these bytes using this -option. - -=item C<< Transparent => 0|1 >> - -If this option is set and the input file/buffer is not compressed data, -the module will allow reading of it anyway. - -In addition, if the input file/buffer does contain compressed data and -there is non-compressed data immediately following it, setting this option -will make this module treat the whole file/bufffer as a single data stream. - -This option defaults to 1. - -=item C<< BlockSize => $num >> - -When reading the compressed input data, IO::Uncompress::RawInflate will read it in -blocks of C<$num> bytes. - -This option defaults to 4096. - -=item C<< InputLength => $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 C<< Append => 0|1 >> - -This option controls what the C<read> method does with uncompressed data. - -If set to 1, all uncompressed data will be appended to the output parameter -of the C<read> method. - -If set to 0, the contents of the output parameter of the C<read> method -will be overwritten by the uncompressed data. - -Defaults to 0. - -=item C<< Strict => 0|1 >> - -This option is a no-op. - -=back - -=head2 Examples - -TODO - -=head1 Methods - -=head2 read - -Usage is - - $status = $z->read($buffer) - -Reads a block of compressed data (the size the the compressed block is -determined by the C<Buffer> option in the constructor), uncompresses it and -writes any uncompressed data into C<$buffer>. If the C<Append> parameter is -set in the constructor, the uncompressed data will be appended to the -C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 read - -Usage is - - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - - $status = read($z, $buffer, $length) - $status = read($z, $buffer, $length, $offset) - -Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. - -The main difference between this form of the C<read> method and the -previous one, is that this one will attempt to return I<exactly> C<$length> -bytes. The only circumstances that this function will not is if end-of-file -or an IO error is encountered. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 getline - -Usage is - - $line = $z->getline() - $line = <$z> - -Reads a single line. - -This method fully supports the use of of the variable C<$/> (or -C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to -determine what constitutes an end of line. Paragraph mode, record mode and -file slurp mode are all supported. - -=head2 getc - -Usage is - - $char = $z->getc() - -Read a single character. - -=head2 ungetc - -Usage is - - $char = $z->ungetc($string) - -=head2 inflateSync - -Usage is - - $status = $z->inflateSync() - -TODO - -=head2 getHeaderInfo - -Usage is - - $hdr = $z->getHeaderInfo(); - @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<seek> functionality, with the restriction -that it is only legal to seek forward in the input file/buffer. -It is a fatal error to attempt to seek backward. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<EXPR> 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, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<undef>. - -=head2 close - - $z->close() ; - close $z ; - -Closes the output file/buffer. - -For most versions of Perl this method will be automatically invoked if -the IO::Uncompress::RawInflate object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Uncompress::RawInflate -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 nextStream - -Usage is - - my $status = $z->nextStream(); - -Skips to the next compressed data stream in the input file/buffer. If a new -compressed data stream is found, the eof marker will be cleared and C<$.> -will be reset to 0. - -Returns 1 if a new stream was found, 0 if none was found, and -1 if an -error was encountered. - -=head2 trailingData - -Usage is - - my $data = $z->trailingData(); - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. It only makes sense to call -this method once the end of the compressed data stream has been -encountered. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option in the constructor. - -=head1 Importing - -No symbolic constants are required by this IO::Uncompress::RawInflate at present. - -=over 5 - -=item :all - -Imports C<rawinflate> and C<$RawInflateError>. -Same as doing this - - use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; - -=back - -=head1 EXAMPLES - -=head2 Working with Net::FTP - -See L<IO::Uncompress::RawInflate::FAQ|IO::Uncompress::RawInflate::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/lib/IO/Uncompress/Unzip.pm b/ext/IO-Compress/lib/IO/Uncompress/Unzip.pm deleted file mode 100644 index 7d08c84edc..0000000000 --- a/ext/IO-Compress/lib/IO/Uncompress/Unzip.pm +++ /dev/null @@ -1,1508 +0,0 @@ -package IO::Uncompress::Unzip; - -require 5.004 ; - -# for RFC1952 - -use strict ; -use warnings; -use bytes; - -use IO::Uncompress::RawInflate 2.021 ; -use IO::Compress::Base::Common 2.021 qw(:Status createSelfTiedObject); -use IO::Uncompress::Adapter::Inflate 2.021 ; -use IO::Uncompress::Adapter::Identity 2.021 ; -use IO::Compress::Zlib::Extra 2.021 ; -use IO::Compress::Zip::Constants 2.021 ; - -use Compress::Raw::Zlib 2.021 qw(crc32) ; - -BEGIN -{ - eval { require IO::Uncompress::Adapter::Bunzip2 ; - import IO::Uncompress::Adapter::Bunzip2 } ; - eval { require IO::Uncompress::Adapter::UnLzma ; - import IO::Uncompress::Adapter::UnLzma } ; -} - - -require Exporter ; - -our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup); - -$VERSION = '2.021'; -$UnzipError = ''; - -@ISA = qw(Exporter IO::Uncompress::RawInflate); -@EXPORT_OK = qw( $UnzipError unzip ); -%EXPORT_TAGS = %IO::Uncompress::RawInflate::EXPORT_TAGS ; -push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; -Exporter::export_ok_tags('all'); - -%headerLookup = ( - ZIP_CENTRAL_HDR_SIG, \&skipCentralDirectory, - ZIP_END_CENTRAL_HDR_SIG, \&skipEndCentralDirectory, - ZIP64_END_CENTRAL_REC_HDR_SIG, \&skipCentralDirectory64Rec, - ZIP64_END_CENTRAL_LOC_HDR_SIG, \&skipCentralDirectory64Loc, - ZIP64_ARCHIVE_EXTRA_SIG, \&skipArchiveExtra, - ZIP64_DIGITAL_SIGNATURE_SIG, \&skipDigitalSignature, - ); - -sub new -{ - my $class = shift ; - my $obj = createSelfTiedObject($class, \$UnzipError); - $obj->_create(undef, 0, @_); -} - -sub unzip -{ - my $obj = createSelfTiedObject(undef, \$UnzipError); - return $obj->_inf(@_) ; -} - -sub getExtraParams -{ - use IO::Compress::Base::Common 2.021 qw(:Parse); - - - return ( -# # Zip header fields - 'Name' => [1, 1, Parse_any, undef], - -# 'Stream' => [1, 1, Parse_boolean, 1], - # This means reading the central directory to get - # 1. the local header offsets - # 2. The compressed data length - ); -} - -sub ckParams -{ - my $self = shift ; - my $got = shift ; - - # unzip always needs crc32 - $got->value('CRC32' => 1); - - *$self->{UnzipData}{Name} = $got->value('Name'); - - return 1; -} - -sub mkUncomp -{ - my $self = shift ; - my $got = shift ; - - my $magic = $self->ckMagic() - or return 0; - - *$self->{Info} = $self->readHeader($magic) - or return undef ; - - return 1; - -} - -sub ckMagic -{ - my $self = shift; - - my $magic ; - $self->smartReadExact(\$magic, 4); - - *$self->{HeaderPending} = $magic ; - - return $self->HeaderError("Minimum header size is " . - 4 . " bytes") - if length $magic != 4 ; - - return $self->HeaderError("Bad Magic") - if ! _isZipMagic($magic) ; - - *$self->{Type} = 'zip'; - - return $magic ; -} - - -sub fastForward -{ - my $self = shift; - my $offset = shift; - - # TODO - if Stream isn't enabled & reading from file, use seek - - my $buffer = ''; - my $c = 1024 * 16; - - while ($offset > 0) - { - $c = length $offset - if length $offset < $c ; - - $offset -= $c; - - $self->smartReadExact(\$buffer, $c) - or return 0; - } - - return 1; -} - - -sub readHeader -{ - my $self = shift; - my $magic = shift ; - - my $name = *$self->{UnzipData}{Name} ; - my $hdr = $self->_readZipHeader($magic) ; - - while (defined $hdr) - { - if (! defined $name || $hdr->{Name} eq $name) - { - return $hdr ; - } - - # skip the data - # TODO - when Stream is off, use seek - my $buffer; - if (*$self->{ZipData}{Streaming}) { - - while (1) { - - my $b; - my $status = $self->smartRead(\$b, 1024 * 16); - return undef - if $status <= 0 ; - - my $temp_buf; - my $out; - $status = *$self->{Uncomp}->uncompr(\$b, \$temp_buf, 0, $out); - - return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, - *$self->{Uncomp}{ErrorNo}) - if $self->saveStatus($status) == STATUS_ERROR; - - if ($status == STATUS_ENDSTREAM) { - *$self->{Uncomp}->reset(); - $self->pushBack($b) ; - last; - } - } - - # skip the trailer - $self->smartReadExact(\$buffer, $hdr->{TrailerLength}) - or return $self->saveErrorString(undef, "Truncated file"); - } - else { - my $c = $hdr->{CompressedLength}->get64bit(); - $self->fastForward($c) - or return $self->saveErrorString(undef, "Truncated file"); - $buffer = ''; - } - - $self->chkTrailer($buffer) == STATUS_OK - or return $self->saveErrorString(undef, "Truncated file"); - - $hdr = $self->_readFullZipHeader(); - - return $self->saveErrorString(undef, "Cannot find '$name'") - if $self->smartEof(); - } - - return undef; -} - -sub chkTrailer -{ - my $self = shift; - my $trailer = shift; - - my ($sig, $CRC32, $cSize, $uSize) ; - my ($cSizeHi, $uSizeHi) = (0, 0); - if (*$self->{ZipData}{Streaming}) { - $sig = unpack ("V", substr($trailer, 0, 4)); - $CRC32 = unpack ("V", substr($trailer, 4, 4)); - - if (*$self->{ZipData}{Zip64} ) { - $cSize = U64::newUnpack_V64 substr($trailer, 8, 8); - $uSize = U64::newUnpack_V64 substr($trailer, 16, 8); - } - else { - $cSize = U64::newUnpack_V32 substr($trailer, 8, 4); - $uSize = U64::newUnpack_V32 substr($trailer, 12, 4); - } - - return $self->TrailerError("Data Descriptor signature, got $sig") - if $sig != ZIP_DATA_HDR_SIG; - } - else { - ($CRC32, $cSize, $uSize) = - (*$self->{ZipData}{Crc32}, - *$self->{ZipData}{CompressedLen}, - *$self->{ZipData}{UnCompressedLen}); - } - - *$self->{Info}{CRC32} = *$self->{ZipData}{CRC32} ; - *$self->{Info}{CompressedLength} = $cSize->get64bit(); - *$self->{Info}{UncompressedLength} = $uSize->get64bit(); - - if (*$self->{Strict}) { - return $self->TrailerError("CRC mismatch") - if $CRC32 != *$self->{ZipData}{CRC32} ; - - return $self->TrailerError("CSIZE mismatch.") - if ! $cSize->equal(*$self->{CompSize}); - - return $self->TrailerError("USIZE mismatch.") - if ! $uSize->equal(*$self->{UnCompSize}); - } - - my $reachedEnd = STATUS_ERROR ; - # check for central directory or end of central directory - while (1) - { - my $magic ; - my $got = $self->smartRead(\$magic, 4); - - return $self->saveErrorString(STATUS_ERROR, "Truncated file") - if $got != 4 && *$self->{Strict}; - - if ($got == 0) { - return STATUS_EOF ; - } - elsif ($got < 0) { - return STATUS_ERROR ; - } - elsif ($got < 4) { - $self->pushBack($magic) ; - return STATUS_OK ; - } - - my $sig = unpack("V", $magic) ; - - my $hdr; - if ($hdr = $headerLookup{$sig}) - { - if (&$hdr($self, $magic) != STATUS_OK ) { - if (*$self->{Strict}) { - return STATUS_ERROR ; - } - else { - $self->clearError(); - return STATUS_OK ; - } - } - - if ($sig == ZIP_END_CENTRAL_HDR_SIG) - { - return STATUS_OK ; - last; - } - } - elsif ($sig == ZIP_LOCAL_HDR_SIG) - { - $self->pushBack($magic) ; - return STATUS_OK ; - } - else - { - # put the data back - $self->pushBack($magic) ; - last; - } - } - - return $reachedEnd ; -} - -sub skipCentralDirectory -{ - my $self = shift; - my $magic = shift ; - - my $buffer; - $self->smartReadExact(\$buffer, 46 - 4) - or return $self->TrailerError("Minimum header size is " . - 46 . " bytes") ; - - my $keep = $magic . $buffer ; - *$self->{HeaderPending} = $keep ; - - #my $versionMadeBy = unpack ("v", substr($buffer, 4-4, 2)); - #my $extractVersion = unpack ("v", substr($buffer, 6-4, 2)); - #my $gpFlag = unpack ("v", substr($buffer, 8-4, 2)); - #my $compressedMethod = unpack ("v", substr($buffer, 10-4, 2)); - #my $lastModTime = unpack ("V", substr($buffer, 12-4, 4)); - #my $crc32 = unpack ("V", substr($buffer, 16-4, 4)); - my $compressedLength = unpack ("V", substr($buffer, 20-4, 4)); - my $uncompressedLength = unpack ("V", substr($buffer, 24-4, 4)); - my $filename_length = unpack ("v", substr($buffer, 28-4, 2)); - my $extra_length = unpack ("v", substr($buffer, 30-4, 2)); - my $comment_length = unpack ("v", substr($buffer, 32-4, 2)); - #my $disk_start = unpack ("v", substr($buffer, 34-4, 2)); - #my $int_file_attrib = unpack ("v", substr($buffer, 36-4, 2)); - #my $ext_file_attrib = unpack ("V", substr($buffer, 38-4, 2)); - #my $lcl_hdr_offset = unpack ("V", substr($buffer, 42-4, 2)); - - - my $filename; - my $extraField; - my $comment ; - if ($filename_length) - { - $self->smartReadExact(\$filename, $filename_length) - or return $self->TruncatedTrailer("filename"); - $keep .= $filename ; - } - - if ($extra_length) - { - $self->smartReadExact(\$extraField, $extra_length) - or return $self->TruncatedTrailer("extra"); - $keep .= $extraField ; - } - - if ($comment_length) - { - $self->smartReadExact(\$comment, $comment_length) - or return $self->TruncatedTrailer("comment"); - $keep .= $comment ; - } - - return STATUS_OK ; -} - -sub skipArchiveExtra -{ - my $self = shift; - my $magic = shift ; - - my $buffer; - $self->smartReadExact(\$buffer, 4) - or return $self->TrailerError("Minimum header size is " . - 4 . " bytes") ; - - my $keep = $magic . $buffer ; - - my $size = unpack ("V", $buffer); - - $self->smartReadExact(\$buffer, $size) - or return $self->TrailerError("Minimum header size is " . - $size . " bytes") ; - - $keep .= $buffer ; - *$self->{HeaderPending} = $keep ; - - return STATUS_OK ; -} - - -sub skipCentralDirectory64Rec -{ - my $self = shift; - my $magic = shift ; - - my $buffer; - $self->smartReadExact(\$buffer, 8) - or return $self->TrailerError("Minimum header size is " . - 8 . " bytes") ; - - my $keep = $magic . $buffer ; - - my ($sizeLo, $sizeHi) = unpack ("V V", $buffer); - my $size = $sizeHi * 0xFFFFFFFF + $sizeLo; - - $self->fastForward($size) - or return $self->TrailerError("Minimum header size is " . - $size . " bytes") ; - - #$keep .= $buffer ; - #*$self->{HeaderPending} = $keep ; - - #my $versionMadeBy = unpack ("v", substr($buffer, 0, 2)); - #my $extractVersion = unpack ("v", substr($buffer, 2, 2)); - #my $diskNumber = unpack ("V", substr($buffer, 4, 4)); - #my $cntrlDirDiskNo = unpack ("V", substr($buffer, 8, 4)); - #my $entriesInThisCD = unpack ("V V", substr($buffer, 12, 8)); - #my $entriesInCD = unpack ("V V", substr($buffer, 20, 8)); - #my $sizeOfCD = unpack ("V V", substr($buffer, 28, 8)); - #my $offsetToCD = unpack ("V V", substr($buffer, 36, 8)); - - return STATUS_OK ; -} - -sub skipCentralDirectory64Loc -{ - my $self = shift; - my $magic = shift ; - - my $buffer; - $self->smartReadExact(\$buffer, 20 - 4) - or return $self->TrailerError("Minimum header size is " . - 20 . " bytes") ; - - my $keep = $magic . $buffer ; - *$self->{HeaderPending} = $keep ; - - #my $startCdDisk = unpack ("V", substr($buffer, 4-4, 4)); - #my $offsetToCD = unpack ("V V", substr($buffer, 8-4, 8)); - #my $diskCount = unpack ("V", substr($buffer, 16-4, 4)); - - return STATUS_OK ; -} - -sub skipEndCentralDirectory -{ - my $self = shift; - my $magic = shift ; - - my $buffer; - $self->smartReadExact(\$buffer, 22 - 4) - or return $self->TrailerError("Minimum header size is " . - 22 . " bytes") ; - - my $keep = $magic . $buffer ; - *$self->{HeaderPending} = $keep ; - - #my $diskNumber = unpack ("v", substr($buffer, 4-4, 2)); - #my $cntrlDirDiskNo = unpack ("v", substr($buffer, 6-4, 2)); - #my $entriesInThisCD = unpack ("v", substr($buffer, 8-4, 2)); - #my $entriesInCD = unpack ("v", substr($buffer, 10-4, 2)); - #my $sizeOfCD = unpack ("V", substr($buffer, 12-4, 2)); - #my $offsetToCD = unpack ("V", substr($buffer, 16-4, 2)); - my $comment_length = unpack ("v", substr($buffer, 20-4, 2)); - - - my $comment ; - if ($comment_length) - { - $self->smartReadExact(\$comment, $comment_length) - or return $self->TruncatedTrailer("comment"); - $keep .= $comment ; - } - - return STATUS_OK ; -} - - -sub _isZipMagic -{ - my $buffer = shift ; - return 0 if length $buffer < 4 ; - my $sig = unpack("V", $buffer) ; - return $sig == ZIP_LOCAL_HDR_SIG ; -} - - -sub _readFullZipHeader($) -{ - my ($self) = @_ ; - my $magic = '' ; - - $self->smartReadExact(\$magic, 4); - - *$self->{HeaderPending} = $magic ; - - return $self->HeaderError("Minimum header size is " . - 30 . " bytes") - if length $magic != 4 ; - - - return $self->HeaderError("Bad Magic") - if ! _isZipMagic($magic) ; - - my $status = $self->_readZipHeader($magic); - delete *$self->{Transparent} if ! defined $status ; - return $status ; -} - -sub _readZipHeader($) -{ - my ($self, $magic) = @_ ; - my ($HeaderCRC) ; - my ($buffer) = '' ; - - $self->smartReadExact(\$buffer, 30 - 4) - or return $self->HeaderError("Minimum header size is " . - 30 . " bytes") ; - - my $keep = $magic . $buffer ; - *$self->{HeaderPending} = $keep ; - - my $extractVersion = unpack ("v", substr($buffer, 4-4, 2)); - my $gpFlag = unpack ("v", substr($buffer, 6-4, 2)); - my $compressedMethod = unpack ("v", substr($buffer, 8-4, 2)); - my $lastModTime = unpack ("V", substr($buffer, 10-4, 4)); - my $crc32 = unpack ("V", substr($buffer, 14-4, 4)); - my $compressedLength = U64::newUnpack_V32 substr($buffer, 18-4, 4); - my $uncompressedLength = U64::newUnpack_V32 substr($buffer, 22-4, 4); - my $filename_length = unpack ("v", substr($buffer, 26-4, 2)); - my $extra_length = unpack ("v", substr($buffer, 28-4, 2)); - - my $filename; - my $extraField; - my @EXTRA = (); - my $streamingMode = ($gpFlag & ZIP_GP_FLAG_STREAMING_MASK) ? 1 : 0 ; - - return $self->HeaderError("Streamed Stored content not supported") - if $streamingMode && $compressedMethod == 0 ; - - return $self->HeaderError("Encrypted content not supported") - if $gpFlag & (ZIP_GP_FLAG_ENCRYPTED_MASK|ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK); - - return $self->HeaderError("Patch content not supported") - if $gpFlag & ZIP_GP_FLAG_PATCHED_MASK; - - *$self->{ZipData}{Streaming} = $streamingMode; - - - if ($filename_length) - { - $self->smartReadExact(\$filename, $filename_length) - or return $self->TruncatedHeader("Filename"); - $keep .= $filename ; - } - - my $zip64 = 0 ; - - if ($extra_length) - { - $self->smartReadExact(\$extraField, $extra_length) - or return $self->TruncatedHeader("Extra Field"); - - my $bad = IO::Compress::Zlib::Extra::parseRawExtra($extraField, - \@EXTRA, 1, 0); - return $self->HeaderError($bad) - if defined $bad; - - $keep .= $extraField ; - - my %Extra ; - for (@EXTRA) - { - $Extra{$_->[0]} = \$_->[1]; - } - - if (defined $Extra{ZIP_EXTRA_ID_ZIP64()}) - { - $zip64 = 1 ; - - my $buff = ${ $Extra{ZIP_EXTRA_ID_ZIP64()} }; - - # This code assumes that all the fields in the Zip64 - # extra field aren't necessarily present. The spec says that - # they only exist if the equivalent local headers are -1. - - if (! $streamingMode) { - my $offset = 0 ; - - if ($uncompressedLength->get32bit() == 0xFFFFFFFF ) { - $uncompressedLength - = U64::newUnpack_V64 substr($buff, 0, 8); - - $offset += 8 ; - } - - if ($compressedLength->get32bit() == 0xFFFFFFFF) { - - $compressedLength - = U64::newUnpack_V64 substr($buff, $offset, 8); - - $offset += 8 ; - } - } - } - } - - *$self->{ZipData}{Zip64} = $zip64; - - if (! $streamingMode) { - *$self->{ZipData}{Streaming} = 0; - *$self->{ZipData}{Crc32} = $crc32; - *$self->{ZipData}{CompressedLen} = $compressedLength; - *$self->{ZipData}{UnCompressedLen} = $uncompressedLength; - *$self->{CompressedInputLengthRemaining} = - *$self->{CompressedInputLength} = $compressedLength->get64bit(); - } - - *$self->{ZipData}{CRC32} = crc32(undef); - *$self->{ZipData}{Method} = $compressedMethod; - if ($compressedMethod == ZIP_CM_DEFLATE) - { - *$self->{Type} = 'zip-deflate'; - my $obj = IO::Uncompress::Adapter::Inflate::mkUncompObject(1,0,0); - - *$self->{Uncomp} = $obj; - } - elsif ($compressedMethod == ZIP_CM_BZIP2) - { - return $self->HeaderError("Unsupported Compression format $compressedMethod") - if ! defined $IO::Uncompress::Adapter::Bunzip2::VERSION ; - - *$self->{Type} = 'zip-bzip2'; - - my $obj = IO::Uncompress::Adapter::Bunzip2::mkUncompObject(); - - *$self->{Uncomp} = $obj; - } - elsif ($compressedMethod == ZIP_CM_LZMA) - { - return $self->HeaderError("Unsupported Compression format $compressedMethod") - if ! defined $IO::Uncompress::Adapter::UnLzma::VERSION ; - - *$self->{Type} = 'zip-lzma'; - my $LzmaHeader; - $self->smartReadExact(\$LzmaHeader, 4) - or return $self->saveErrorString(undef, "Truncated file"); - my ($verHi, $verLo) = unpack ("CC", substr($LzmaHeader, 0, 2)); - my $LzmaPropertiesSize = unpack ("v", substr($LzmaHeader, 2, 2)); - - - my $LzmaPropertyData; - $self->smartReadExact(\$LzmaPropertyData, $LzmaPropertiesSize) - or return $self->saveErrorString(undef, "Truncated file"); - #my $LzmaInfo = unpack ("C", substr($LzmaPropertyData, 0, 1)); - #my $LzmaDictSize = unpack ("V", substr($LzmaPropertyData, 1, 4)); - - # Create an LZMA_Alone header - $self->pushBack($LzmaPropertyData . - $uncompressedLength->getPacked_V64()); - - my $obj = - IO::Uncompress::Adapter::UnLzma::mkUncompObject(); - - *$self->{Uncomp} = $obj; - } - elsif ($compressedMethod == ZIP_CM_STORE) - { - # TODO -- add support for reading uncompressed - - *$self->{Type} = 'zip-stored'; - - my $obj = IO::Uncompress::Adapter::Identity::mkUncompObject(); - - *$self->{Uncomp} = $obj; - } - else - { - return $self->HeaderError("Unsupported Compression format $compressedMethod"); - } - - return { - 'Type' => 'zip', - 'FingerprintLength' => 4, - #'HeaderLength' => $compressedMethod == 8 ? length $keep : 0, - 'HeaderLength' => length $keep, - 'Zip64' => $zip64, - 'TrailerLength' => ! $streamingMode ? 0 : $zip64 ? 24 : 16, - 'Header' => $keep, - 'CompressedLength' => $compressedLength , - 'UncompressedLength' => $uncompressedLength , - 'CRC32' => $crc32 , - 'Name' => $filename, - 'Time' => _dosToUnixTime($lastModTime), - 'Stream' => $streamingMode, - - 'MethodID' => $compressedMethod, - 'MethodName' => $compressedMethod == ZIP_CM_DEFLATE - ? "Deflated" - : $compressedMethod == ZIP_CM_BZIP2 - ? "Bzip2" - : $compressedMethod == ZIP_CM_LZMA - ? "Lzma" - : $compressedMethod == ZIP_CM_STORE - ? "Stored" - : "Unknown" , - -# 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0, -# 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0, -# 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0, -# 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0, -# 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0, -# 'Comment' => $comment, -# 'OsID' => $os, -# 'OsName' => defined $GZIP_OS_Names{$os} -# ? $GZIP_OS_Names{$os} : "Unknown", -# 'HeaderCRC' => $HeaderCRC, -# 'Flags' => $flag, -# 'ExtraFlags' => $xfl, - 'ExtraFieldRaw' => $extraField, - 'ExtraField' => [ @EXTRA ], - - - } -} - -sub filterUncompressed -{ - my $self = shift ; - - if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { - *$self->{ZipData}{CRC32} = *$self->{Uncomp}->crc32() ; - } - else { - *$self->{ZipData}{CRC32} = crc32(${$_[0]}, *$self->{ZipData}{CRC32}); - } -} - - -# from Archive::Zip & info-zip -sub _dosToUnixTime -{ - my $dt = shift; - - my $year = ( ( $dt >> 25 ) & 0x7f ) + 80; - my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1; - my $mday = ( ( $dt >> 16 ) & 0x1f ); - - my $hour = ( ( $dt >> 11 ) & 0x1f ); - my $min = ( ( $dt >> 5 ) & 0x3f ); - my $sec = ( ( $dt << 1 ) & 0x3e ); - - - use POSIX 'mktime'; - - my $time_t = mktime( $sec, $min, $hour, $mday, $mon, $year, 0, 0, -1 ); - return 0 if ! defined $time_t; - return $time_t; -} - - -1; - -__END__ - - -=head1 NAME - -IO::Uncompress::Unzip - Read zip files/buffers - -=head1 SYNOPSIS - - use IO::Uncompress::Unzip qw(unzip $UnzipError) ; - - my $status = unzip $input => $output [,OPTS] - or die "unzip failed: $UnzipError\n"; - - my $z = new IO::Uncompress::Unzip $input [OPTS] - or die "unzip failed: $UnzipError\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() - - $status = $z->inflateSync() - - $data = $z->trailingData() - $status = $z->nextStream() - $data = $z->getHeaderInfo() - $z->tell() - $z->seek($position, $whence) - $z->binmode() - $z->fileno() - $z->eof() - $z->close() - - $UnzipError ; - - # 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 - -This module provides a Perl interface that allows the reading of -zlib files/buffers. - -For writing zip files/buffers, see the companion module IO::Compress::Zip. - -=head1 Functional Interface - -A top-level function, C<unzip>, is provided to carry out -"one-shot" uncompression between buffers and/or files. For finer -control over the uncompression process, see the L</"OO Interface"> -section. - - use IO::Uncompress::Unzip qw(unzip $UnzipError) ; - - unzip $input => $output [,OPTS] - or die "unzip failed: $UnzipError\n"; - -The functional interface needs Perl5.005 or better. - -=head2 unzip $input => $output [, OPTS] - -C<unzip> 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<unzip> will assume that it is an I<input fileglob string>. The -input is the list of files that match the fileglob. - -If the fileglob does not match any files ... - -See L<File::GlobMapper|File::GlobMapper> for more details. - -=back - -If the C<$input> parameter is any other type, C<undef> will be returned. - -=head3 The C<$output> parameter - -The parameter C<$output> is used to control the destination of the -uncompressed data. This parameter can take one of these forms. - -=over 5 - -=item A filename - -If the C<$output> parameter is a simple scalar, it is assumed to be a -filename. This file will be opened for writing and the uncompressed -data will be written to it. - -=item A filehandle - -If the C<$output> parameter is a filehandle, the uncompressed data -will be written to it. -The string '-' can be used as an alias for standard output. - -=item A scalar reference - -If C<$output> is a scalar reference, the uncompressed data will be -stored in C<$$output>. - -=item 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<unzip> will assume that it is an I<output fileglob string>. The -output is the list of files that match the fileglob. - -When C<$output> is an fileglob string, C<$input> must also be a fileglob -string. Anything else is an error. - -=back - -If the C<$output> parameter is any other type, C<undef> will be returned. - -=head2 Notes - -When C<$input> maps to multiple compressed files/buffers and C<$output> is -a single file/buffer, after uncompression C<$output> will contain a -concatenation of all the uncompressed data from each of the input -files/buffers. - -=head2 Optional Parameters - -Unless specified below, the optional parameters for C<unzip>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option applies to any input or output data streams to -C<unzip> that are filehandles. - -If C<AutoClose> is specified, and the value is true, it will result in all -input and/or output filehandles being closed once C<unzip> has -completed. - -This parameter defaults to 0. - -=item C<< BinModeOut => 0|1 >> - -When writing to a file or filehandle, set C<binmode> before writing to the -file. - -Defaults to 0. - -=item C<< Append => 0|1 >> - -TODO - -=item C<< MultiStream => 0|1 >> - -If the input file/buffer contains multiple compressed data streams, this -option will uncompress the whole lot as a single data stream. - -Defaults to 0. - -=item C<< TrailingData => $scalar >> - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option. - -=back - -=head2 Examples - -To read the contents of the file C<file1.txt.zip> and write the -uncompressed data to the file C<file1.txt>. - - use strict ; - use warnings ; - use IO::Uncompress::Unzip qw(unzip $UnzipError) ; - - my $input = "file1.txt.zip"; - my $output = "file1.txt"; - unzip $input => $output - or die "unzip failed: $UnzipError\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::Unzip qw(unzip $UnzipError) ; - use IO::File ; - - my $input = new IO::File "<file1.txt.zip" - or die "Cannot open 'file1.txt.zip': $!\n" ; - my $buffer ; - unzip $input => \$buffer - or die "unzip failed: $UnzipError\n"; - -To uncompress all files in the directory "/my/home" that match "*.txt.zip" and store the compressed data in the same directory - - use strict ; - use warnings ; - use IO::Uncompress::Unzip qw(unzip $UnzipError) ; - - unzip '</my/home/*.txt.zip>' => '</my/home/#1.txt>' - or die "unzip failed: $UnzipError\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::Unzip qw(unzip $UnzipError) ; - - for my $input ( glob "/my/home/*.txt.zip" ) - { - my $output = $input; - $output =~ s/.zip// ; - unzip $input => $output - or die "Error compressing '$input': $UnzipError\n"; - } - -=head1 OO Interface - -=head2 Constructor - -The format of the constructor for IO::Uncompress::Unzip is shown below - - my $z = new IO::Uncompress::Unzip $input [OPTS] - or die "IO::Uncompress::Unzip failed: $UnzipError\n"; - -Returns an C<IO::Uncompress::Unzip> object on success and undef on failure. -The variable C<$UnzipError> will contain an error message on failure. - -If you are running Perl 5.005 or better the object, C<$z>, returned from -IO::Uncompress::Unzip can be used exactly like an L<IO::File|IO::File> filehandle. -This means that all normal input file operations can be carried out with -C<$z>. For example, to read a line from a compressed file/buffer you can -use either of these forms - - $line = $z->getline(); - $line = <$z>; - -The mandatory parameter C<$input> is used to determine the source of the -compressed data. This parameter can take one of three forms. - -=over 5 - -=item A filename - -If the C<$input> parameter is a scalar, it is assumed to be a filename. This -file will be opened for reading and the compressed data will be read from it. - -=item A filehandle - -If the C<$input> parameter is a filehandle, the compressed data will be -read from it. -The string '-' can be used as an alias for standard input. - -=item A scalar reference - -If C<$input> is a scalar reference, the compressed data will be read from -C<$$output>. - -=back - -=head2 Constructor Options - -The option names defined below are case insensitive and can be optionally -prefixed by a '-'. So all of the following are valid - - -AutoClose - -autoclose - AUTOCLOSE - autoclose - -OPTS is a combination of the following options: - -=over 5 - -=item C<< AutoClose => 0|1 >> - -This option is only valid when the C<$input> parameter is a filehandle. If -specified, and the value is true, it will result in the file being closed once -either the C<close> method is called or the IO::Uncompress::Unzip object is -destroyed. - -This parameter defaults to 0. - -=item C<< MultiStream => 0|1 >> - -Treats the complete zip file/buffer as a single compressed data -stream. When reading in multi-stream mode each member of the zip -file/buffer will be uncompressed in turn until the end of the file/buffer -is encountered. - -This parameter defaults to 0. - -=item C<< Prime => $string >> - -This option will uncompress the contents of C<$string> before processing the -input file/buffer. - -This option can be useful when the compressed data is embedded in another -file/data structure and it is not possible to work out where the compressed -data begins without having to read the first few bytes. If this is the -case, the uncompression can be I<primed> with these bytes using this -option. - -=item C<< Transparent => 0|1 >> - -If this option is set and the input file/buffer is not compressed data, -the module will allow reading of it anyway. - -In addition, if the input file/buffer does contain compressed data and -there is non-compressed data immediately following it, setting this option -will make this module treat the whole file/bufffer as a single data stream. - -This option defaults to 1. - -=item C<< BlockSize => $num >> - -When reading the compressed input data, IO::Uncompress::Unzip will read it in -blocks of C<$num> bytes. - -This option defaults to 4096. - -=item C<< InputLength => $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 C<< Append => 0|1 >> - -This option controls what the C<read> method does with uncompressed data. - -If set to 1, all uncompressed data will be appended to the output parameter -of the C<read> method. - -If set to 0, the contents of the output parameter of the C<read> method -will be overwritten by the uncompressed data. - -Defaults to 0. - -=item C<< Strict => 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<Buffer> option in the constructor), uncompresses it and -writes any uncompressed data into C<$buffer>. If the C<Append> parameter is -set in the constructor, the uncompressed data will be appended to the -C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 read - -Usage is - - $status = $z->read($buffer, $length) - $status = $z->read($buffer, $length, $offset) - - $status = read($z, $buffer, $length) - $status = read($z, $buffer, $length, $offset) - -Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. - -The main difference between this form of the C<read> method and the -previous one, is that this one will attempt to return I<exactly> C<$length> -bytes. The only circumstances that this function will not is if end-of-file -or an IO error is encountered. - -Returns the number of uncompressed bytes written to C<$buffer>, zero if eof -or a negative number on error. - -=head2 getline - -Usage is - - $line = $z->getline() - $line = <$z> - -Reads a single line. - -This method fully supports the use of of the variable C<$/> (or -C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to -determine what constitutes an end of line. Paragraph mode, record mode and -file slurp mode are all supported. - -=head2 getc - -Usage is - - $char = $z->getc() - -Read a single character. - -=head2 ungetc - -Usage is - - $char = $z->ungetc($string) - -=head2 inflateSync - -Usage is - - $status = $z->inflateSync() - -TODO - -=head2 getHeaderInfo - -Usage is - - $hdr = $z->getHeaderInfo(); - @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<seek> functionality, with the restriction -that it is only legal to seek forward in the input file/buffer. -It is a fatal error to attempt to seek backward. - -The C<$whence> parameter takes one the usual values, namely SEEK_SET, -SEEK_CUR or SEEK_END. - -Returns 1 on success, 0 on failure. - -=head2 binmode - -Usage is - - $z->binmode - binmode $z ; - -This is a noop provided for completeness. - -=head2 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<EXPR> 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<undef>. - -B<Note> that the special variable C<$|> B<cannot> 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<EXPR> 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, C<fileno> -will return the underlying file descriptor. Once the C<close> method is -called C<fileno> will return C<undef>. - -If the C<$z> object is is associated with a buffer, this method will return -C<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::Unzip object is destroyed (either explicitly or by the -variable with the reference to the object going out of scope). The -exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In -these cases, the C<close> method will be called automatically, but -not until global destruction of all live objects when the program is -terminating. - -Therefore, if you want your scripts to be able to run on all versions -of Perl, you should call C<close> explicitly and not rely on automatic -closing. - -Returns true on success, otherwise 0. - -If the C<AutoClose> option has been enabled when the IO::Uncompress::Unzip -object was created, and the object is associated with a file, the -underlying file will also be closed. - -=head2 nextStream - -Usage is - - my $status = $z->nextStream(); - -Skips to the next compressed data stream in the input file/buffer. If a new -compressed data stream is found, the eof marker will be cleared and C<$.> -will be reset to 0. - -Returns 1 if a new stream was found, 0 if none was found, and -1 if an -error was encountered. - -=head2 trailingData - -Usage is - - my $data = $z->trailingData(); - -Returns the data, if any, that is present immediately after the compressed -data stream once uncompression is complete. It only makes sense to call -this method once the end of the compressed data stream has been -encountered. - -This option can be used when there is useful information immediately -following the compressed data stream, and you don't know the length of the -compressed data stream. - -If the input is a buffer, C<trailingData> will return everything from the -end of the compressed data stream to the end of the buffer. - -If the input is a filehandle, C<trailingData> will return the data that is -left in the filehandle input buffer once the end of the compressed data -stream has been reached. You can then use the filehandle to read the rest -of the input file. - -Don't bother using C<trailingData> if the input is a filename. - -If you know the length of the compressed data stream before you start -uncompressing, you can avoid having to use C<trailingData> by setting the -C<InputLength> option in the constructor. - -=head1 Importing - -No symbolic constants are required by this IO::Uncompress::Unzip at present. - -=over 5 - -=item :all - -Imports C<unzip> and C<$UnzipError>. -Same as doing this - - use IO::Uncompress::Unzip qw(unzip $UnzipError) ; - -=back - -=head1 EXAMPLES - -=head2 Working with Net::FTP - -See L<IO::Uncompress::Unzip::FAQ|IO::Uncompress::Unzip::FAQ/"Compressed files and Net::FTP"> - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -For RFC 1950, 1951 and 1952 see -F<http://www.faqs.org/rfcs/rfc1950.html>, -F<http://www.faqs.org/rfcs/rfc1951.html> and -F<http://www.faqs.org/rfcs/rfc1952.html> - -The I<zlib> compression library was written by Jean-loup Gailly -F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. - -The primary site for the I<zlib> compression library is -F<http://www.zlib.org>. - -The primary site for gzip is F<http://www.gzip.org>. - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/pod/FAQ.pod b/ext/IO-Compress/pod/FAQ.pod deleted file mode 100644 index 0fee2a9f6d..0000000000 --- a/ext/IO-Compress/pod/FAQ.pod +++ /dev/null @@ -1,512 +0,0 @@ - -=head1 NAME - -IO::Compress::FAQ -- Frequently Asked Questions about IO::Compress - -=head1 DESCRIPTION - -Common questions answered. - -=head2 Compatibility with Unix compress/uncompress. - -Although C<Compress::Zlib> has a pair of functions called C<compress> and -C<uncompress>, they are I<not> related to the Unix programs of the same -name. The C<Compress::Zlib> module is not compatible with Unix -C<compress>. - -If you have the C<uncompress> program available, you can use this to read -compressed files - - open F, "uncompress -c $filename |"; - while (<F>) - { - ... - -Alternatively, if you have the C<gunzip> program available, you can use -this to read compressed files - - open F, "gunzip -c $filename |"; - while (<F>) - { - ... - -and this to write compress files, if you have the C<compress> program -available - - open F, "| compress -c $filename "; - print F "data"; - ... - close F ; - -=head2 Accessing .tar.Z files - -The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via the -C<IO::Zlib> module) to access tar files that have been compressed with -C<gzip>. Unfortunately tar files compressed with the Unix C<compress> -utility cannot be read by C<Compress::Zlib> and so cannot be directly -accessed by C<Archive::Tar>. - -If the C<uncompress> or C<gunzip> programs are available, you can use one -of these workarounds to read C<.tar.Z> files from C<Archive::Tar> - -Firstly with C<uncompress> - - use strict; - use warnings; - use Archive::Tar; - - open F, "uncompress -c $filename |"; - my $tar = Archive::Tar->new(*F); - ... - -and this with C<gunzip> - - use strict; - use warnings; - use Archive::Tar; - - open F, "gunzip -c $filename |"; - my $tar = Archive::Tar->new(*F); - ... - -Similarly, if the C<compress> program is available, you can use this to -write a C<.tar.Z> file - - use strict; - use warnings; - use Archive::Tar; - use IO::File; - - my $fh = new IO::File "| compress -c >$filename"; - my $tar = Archive::Tar->new(); - ... - $tar->write($fh); - $fh->close ; - -=head2 Accessing Zip Files - -This module provides support for reading/writing zip files using the -C<IO::Compress::Zip> and C<IO::Uncompress::Unzip> modules. - -The primary focus of the C<IO::Compress::Zip> and C<IO::Uncompress::Unzip> -modules is to provide an C<IO::File> compatible streaming read/write -interface to zip files/buffers. They are not fully flegged archivers. If -you are looking for an archiver check out the C<Archive::Zip> module. You -can find it on CPAN at - - http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz - -=head2 Compressed files and Net::FTP - -The C<Net::FTP> module provides two low-level methods called C<stor> and -C<retr> that both return filehandles. These filehandles can used with the -C<IO::Compress/Uncompress> modules to compress or uncompress files read -from or written to an FTP Server on the fly, without having to create a -temporary file. - -Firstly, here is code that uses C<retr> to uncompressed a file as it is -read from the FTP Server. - - use Net::FTP; - use IO::Uncompress::Gunzip qw(:all); - - my $ftp = new Net::FTP ... - - my $retr_fh = $ftp->retr($compressed_filename); - gunzip $retr_fh => $outFilename, AutoClose => 1 - or die "Cannot uncompress '$compressed_file': $GunzipError\n"; - -and this to compress a file as it is written to the FTP Server - - use Net::FTP; - use IO::Compress::Gzip qw(:all); - - my $stor_fh = $ftp->stor($filename); - gzip "filename" => $stor_fh, AutoClose => 1 - or die "Cannot compress '$filename': $GzipError\n"; - -=head2 How do I recompress using a different compression? - -This is easier that you might expect if you realise that all the -C<IO::Compress::*> objects are derived from C<IO::File> and that all the -C<IO::Uncompress::*> modules can read from an C<IO::File> filehandle. - -So, for example, say you have a file compressed with gzip that you want to -recompress with bzip2. Here is all that is needed to carry out the -recompression. - - use IO::Uncompress::Gunzip ':all'; - use IO::Compress::Bzip2 ':all'; - - my $gzipFile = "somefile.gz"; - my $bzipFile = "somefile.bz2"; - - my $gunzip = new IO::Uncompress::Gunzip $gzipFile - or die "Cannot gunzip $gzipFile: $GunzipError\n" ; - - bzip2 $gunzip => $bzipFile - or die "Cannot bzip2 to $bzipFile: $Bzip2Error\n" ; - -Note, there is a limitation of this technique. Some compression file -formats store extra information along with the compressed data payload. For -example, gzip can optionally store the original filename and Zip stores a -lot of information about the original file. If the original compressed file -contains any of this extra information, it will not be transferred to the -new compressed file usign the technique above. - -=head2 Apache::GZip Revisited - -Below is a mod_perl Apache compression module, called C<Apache::GZip>, -taken from -F<http://perl.apache.org/docs/tutorials/tips/mod_perl_tricks/mod_perl_tricks.html#On_the_Fly_Compression> - - package Apache::GZip; - #File: Apache::GZip.pm - - use strict vars; - use Apache::Constants ':common'; - use Compress::Zlib; - use IO::File; - use constant GZIP_MAGIC => 0x1f8b; - use constant OS_MAGIC => 0x03; - - sub handler { - my $r = shift; - my ($fh,$gz); - my $file = $r->filename; - return DECLINED unless $fh=IO::File->new($file); - $r->header_out('Content-Encoding'=>'gzip'); - $r->send_http_header; - return OK if $r->header_only; - - tie *STDOUT,'Apache::GZip',$r; - print($_) while <$fh>; - untie *STDOUT; - return OK; - } - - sub TIEHANDLE { - my($class,$r) = @_; - # initialize a deflation stream - my $d = deflateInit(-WindowBits=>-MAX_WBITS()) || return undef; - - # gzip header -- don't ask how I found out - $r->print(pack("nccVcc",GZIP_MAGIC,Z_DEFLATED,0,time(),0,OS_MAGIC)); - - return bless { r => $r, - crc => crc32(undef), - d => $d, - l => 0 - },$class; - } - - sub PRINT { - my $self = shift; - foreach (@_) { - # deflate the data - my $data = $self->{d}->deflate($_); - $self->{r}->print($data); - # keep track of its length and crc - $self->{l} += length($_); - $self->{crc} = crc32($_,$self->{crc}); - } - } - - sub DESTROY { - my $self = shift; - - # flush the output buffers - my $data = $self->{d}->flush; - $self->{r}->print($data); - - # print the CRC and the total length (uncompressed) - $self->{r}->print(pack("LL",@{$self}{qw/crc l/})); - } - - 1; - -Here's the Apache configuration entry you'll need to make use of it. Once -set it will result in everything in the /compressed directory will be -compressed automagically. - - <Location /compressed> - SetHandler perl-script - PerlHandler Apache::GZip - </Location> - -Although at first sight there seems to be quite a lot going on in -C<Apache::GZip>, you could sum up what the code was doing as follows -- -read the contents of the file in C<< $r->filename >>, compress it and write -the compressed data to standard output. That's all. - -This code has to jump through a few hoops to achieve this because - -=over - -=item 1. - -The gzip support in C<Compress::Zlib> version 1.x can only work with a real -filesystem filehandle. The filehandles used by Apache modules are not -associated with the filesystem. - -=item 2. - -That means all the gzip support has to be done by hand - in this case by -creating a tied filehandle to deal with creating the gzip header and -trailer. - -=back - -C<IO::Compress::Gzip> doesn't have that filehandle limitation (this was one -of the reasons for writing it in the first place). So if -C<IO::Compress::Gzip> is used instead of C<Compress::Zlib> the whole tied -filehandle code can be removed. Here is the rewritten code. - - package Apache::GZip; - - use strict vars; - use Apache::Constants ':common'; - use IO::Compress::Gzip; - use IO::File; - - sub handler { - my $r = shift; - my ($fh,$gz); - my $file = $r->filename; - return DECLINED unless $fh=IO::File->new($file); - $r->header_out('Content-Encoding'=>'gzip'); - $r->send_http_header; - return OK if $r->header_only; - - my $gz = new IO::Compress::Gzip '-', Minimal => 1 - or return DECLINED ; - - print $gz $_ while <$fh>; - - return OK; - } - -or even more succinctly, like this, using a one-shot gzip - - package Apache::GZip; - - use strict vars; - use Apache::Constants ':common'; - use IO::Compress::Gzip qw(gzip); - - sub handler { - my $r = shift; - $r->header_out('Content-Encoding'=>'gzip'); - $r->send_http_header; - return OK if $r->header_only; - - gzip $r->filename => '-', Minimal => 1 - or return DECLINED ; - - return OK; - } - - 1; - -The use of one-shot C<gzip> above just reads from C<< $r->filename >> and -writes the compressed data to standard output. - -Note the use of the C<Minimal> option in the code above. When using gzip -for Content-Encoding you should I<always> use this option. In the example -above it will prevent the filename being included in the gzip header and -make the size of the gzip data stream a slight bit smaller. - -=head2 Using C<InputLength> to uncompress data embedded in a larger file/buffer. - -A fairly common use-case is where compressed data is embedded in a larger -file/buffer and you want to read both. - -As an example consider the structure of a zip file. This is a well-defined -file format that mixes both compressed and uncompressed sections of data in -a single file. - -For the purposes of this discussion you can think of a zip file as sequence -of compressed data streams, each of which is prefixed by an uncompressed -local header. The local header contains information about the compressed -data stream, including the name of the compressed file and, in particular, -the length of the compressed data stream. - -To illustrate how to use C<InputLength> here is a script that walks a zip -file and prints out how many lines are in each compressed file (if you -intend write code to walking through a zip file for real see -L<IO::Uncompress::Unzip/"Walking through a zip file"> ) - - use strict; - use warnings; - - use IO::File; - use IO::Uncompress::RawInflate qw(:all); - - use constant ZIP_LOCAL_HDR_SIG => 0x04034b50; - use constant ZIP_LOCAL_HDR_LENGTH => 30; - - my $file = $ARGV[0] ; - - my $fh = new IO::File "<$file" - or die "Cannot open '$file': $!\n"; - - while (1) - { - my $sig; - my $buffer; - - my $x ; - ($x = $fh->read($buffer, ZIP_LOCAL_HDR_LENGTH)) == ZIP_LOCAL_HDR_LENGTH - or die "Truncated file: $!\n"; - - my $signature = unpack ("V", substr($buffer, 0, 4)); - - last unless $signature == ZIP_LOCAL_HDR_SIG; - - # Read Local Header - my $gpFlag = unpack ("v", substr($buffer, 6, 2)); - 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)); - - 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; - } - - if ($compressedMethod == 0 && $gpFlag & 8 == 8) - { - die "Streamed Stored not supported for '$filename'\n"; - } - - next if $compressedLength == 0; - - # Done reading the Local Header - - my $inf = new IO::Uncompress::RawInflate $fh, - Transparent => 1, - InputLength => $compressedLength - or die "Cannot uncompress $file [$filename]: $RawInflateError\n" ; - - my $line_count = 0; - - while (<$inf>) - { - ++ $line_count; - } - - print "$filename: $line_count\n"; - } - -The majority of the code above is concerned with reading the zip local -header data. The code that I want to focus on is at the bottom. - - while (1) { - - # read local zip header data - # get $filename - # get $compressedLength - - my $inf = new IO::Uncompress::RawInflate $fh, - Transparent => 1, - InputLength => $compressedLength - or die "Cannot uncompress $file [$filename]: $RawInflateError\n" ; - - my $line_count = 0; - - while (<$inf>) - { - ++ $line_count; - } - - print "$filename: $line_count\n"; - } - -The call to C<IO::Uncompress::RawInflate> creates a new filehandle C<$inf> -that can be used to read from the parent filehandle C<$fh>, uncompressing -it as it goes. The use of the C<InputLength> option will guarantee that -I<at most> C<$compressedLength> bytes of compressed data will be read from -the C<$fh> filehandle (The only exception is for an error case like a -truncated file or a corrupt data stream). - -This means that once RawInflate is finished C<$fh> will be left at the -byte directly after the compressed data stream. - -Now consider what the code looks like without C<InputLength> - - while (1) { - - # read local zip header data - # get $filename - # get $compressedLength - - # read all the compressed data into $data - read($fh, $data, $compressedLength); - - my $inf = new IO::Uncompress::RawInflate \$data, - Transparent => 1, - or die "Cannot uncompress $file [$filename]: $RawInflateError\n" ; - - my $line_count = 0; - - while (<$inf>) - { - ++ $line_count; - } - - print "$filename: $line_count\n"; - } - -The difference here is the addition of the temporary variable C<$data>. -This is used to store a copy of the compressed data while it is being -uncompressed. - -If you know that C<$compressedLength> isn't that big then using temporary -storage won't be a problem. But if C<$compressedLength> is very large or -you are writing an application that other people will use, and so have no -idea how big C<$compressedLength> will be, it could be an issue. - -Using C<InputLength> avoids the use of temporary storage and means the -application can cope with large compressed data streams. - -One final point -- obviously C<InputLength> can only be used whenever you -know the length of the compressed data beforehand, like here with a zip -file. - -=head1 SEE ALSO - -L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> - -L<Compress::Zlib::FAQ|Compress::Zlib::FAQ> - -L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, -L<Archive::Tar|Archive::Tar>, -L<IO::Zlib|IO::Zlib> - -=head1 AUTHOR - -This module was written by Paul Marquess, F<pmqs@cpan.org>. - -=head1 MODIFICATION HISTORY - -See the Changes file. - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2005-2009 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/IO-Compress/private/MakeUtil.pm b/ext/IO-Compress/private/MakeUtil.pm deleted file mode 100644 index 47aebd6074..0000000000 --- a/ext/IO-Compress/private/MakeUtil.pm +++ /dev/null @@ -1,381 +0,0 @@ -package MakeUtil ; -package main ; - -use strict ; - -use Config qw(%Config); -use File::Copy; - -my $VERSION = '1.0'; - - -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'); - - # Note: Once you remove all the layers of shell/makefile escaping - # the regular expression below reads - # - # /^\s*local\s*\(\s*\$^W\s*\)/ - # - 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 (<M>) - { - 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 $do_downgrade ; - - my $caller = (caller(1))[3] || ''; - - if ($caller =~ /downgrade/) - { - $downgrade = 1; - } - elsif ($caller =~ /upgrade/) - { - $upgrade = 1; - } - else - { - $do_downgrade = 1 - if $] < 5.006001 ; - } - -# else -# { -# my $opt = shift @ARGV || '' ; -# $upgrade = ($opt =~ /^-upgrade/i); -# $downgrade = ($opt =~ /^-downgrade/i); -# push @ARGV, $opt unless $downgrade || $upgrade; -# } - - - if ($downgrade || $do_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) { - elsif ($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 || $do_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) { - elsif ($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 (<F>) - { - if (/^__(END|DATA)__/) - { - push @keep, $_; - last ; - } - - &{ $our_sub }() if $our_sub ; - &{ $warn_sub }() if $warn_sub ; - push @keep, $_; - } - - if (! eof F) - { - while (<F>) - { push @keep, $_ } - } - close F; - } - - { - open F, ">$file" - or die "Cannot open $file: $!\n"; - print F @keep ; - close F; - } -} - - -sub FindBrokenDependencies -{ - my $version = shift ; - my %thisModule = map { $_ => 1} @_; - - my @modules = qw( - IO::Compress::Base - IO::Compress::Base::Common - IO::Uncompress::Base - - Compress::Raw::Zlib - Compress::Raw::Bzip2 - - IO::Compress::RawDeflate - IO::Uncompress::RawInflate - IO::Compress::Deflate - IO::Uncompress::Inflate - IO::Compress::Gzip - IO::Compress::Gzip::Constants - IO::Uncompress::Gunzip - IO::Compress::Zip - IO::Uncompress::Unzip - - IO::Compress::Bzip2 - IO::Uncompress::Bunzip2 - - IO::Compress::Lzf - IO::Uncompress::UnLzf - - IO::Compress::Lzop - IO::Uncompress::UnLzop - - Compress::Zlib - ); - - my @broken = (); - - foreach my $module ( grep { ! $thisModule{$_} } @modules) - { - my $hasVersion = getInstalledVersion($module); - - # No need to upgrade if the module isn't installed at all - next - if ! defined $hasVersion; - - # If already have C::Z version 1, then an upgrade to any of the - # IO::Compress modules will not break it. - next - if $module eq 'Compress::Zlib' && $hasVersion < 2; - - if ($hasVersion < $version) - { - push @broken, $module - } - } - - return @broken; -} - -sub getInstalledVersion -{ - my $module = shift; - my $version; - - eval " require $module; "; - - if ($@ eq '') - { - no strict 'refs'; - $version = ${ $module . "::VERSION" }; - $version = 0 - } - - return $version; -} - -package MakeUtil ; - -1; - - diff --git a/ext/IO-Compress/t/000prereq.t b/ext/IO-Compress/t/000prereq.t deleted file mode 100644 index 11b84fd85e..0000000000 --- a/ext/IO-Compress/t/000prereq.t +++ /dev/null @@ -1,98 +0,0 @@ -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 ; - -sub gotScalarUtilXS -{ - eval ' use Scalar::Util "dualvar" '; - return $@ ? 0 : 1 ; -} - -BEGIN -{ - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - - my $VERSION = '2.021'; - my @NAMES = qw( - Compress::Raw::Bzip2 - Compress::Raw::Zlib - - Compress::Zlib - - IO::Compress::Adapter::Bzip2 - IO::Compress::Adapter::Deflate - IO::Compress::Adapter::Identity - IO::Compress::Base::Common - IO::Compress::Base - IO::Compress::Bzip2 - IO::Compress::Deflate - IO::Compress::Gzip::Constants - IO::Compress::Gzip - IO::Compress::RawDeflate - IO::Compress::Zip::Constants - IO::Compress::Zip - IO::Compress::Zlib::Constants - IO::Compress::Zlib::Extra - IO::Uncompress::Adapter::Bunzip2 - IO::Uncompress::Adapter::Identity - IO::Uncompress::Adapter::Inflate - IO::Uncompress::AnyInflate - IO::Uncompress::AnyUncompress - IO::Uncompress::Base - IO::Uncompress::Bunzip2 - IO::Uncompress::Gunzip - IO::Uncompress::Inflate - IO::Uncompress::RawInflate - IO::Uncompress::Unzip - - ); - - my @OPT = qw( - - ); - - plan tests => 2 + @NAMES + @OPT + $extra ; - - foreach my $name (@NAMES) - { - use_ok($name, $VERSION); - } - - - foreach my $name (@OPT) - { - eval " require $name " ; - if ($@) - { - ok 1, "$name not available" - } - else - { - my $ver = eval("\$${name}::VERSION"); - is $ver, $VERSION, "$name version should be $VERSION" - or diag "$name version is $ver, need $VERSION" ; - } - } - - use_ok('Scalar::Util') ; - -} - -ok gotScalarUtilXS(), "Got XS Version of Scalar::Util" - or diag <<EOM; -You don't have the XS version of Scalar::Util -EOM - diff --git a/ext/IO-Compress/t/001bzip2.t b/ext/IO-Compress/t/001bzip2.t deleted file mode 100644 index 40b9bcca59..0000000000 --- a/ext/IO-Compress/t/001bzip2.t +++ /dev/null @@ -1,206 +0,0 @@ -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 => 841 + $extra ; -}; - - -use IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - - -my $CompressClass = 'IO::Compress::Bzip2'; -my $UncompressClass = getInverse($CompressClass); -my $Error = getErrorRef($CompressClass); -my $UnError = getErrorRef($UncompressClass); - -sub myBZreadFile -{ - my $filename = shift ; - my $init = shift ; - - - my $fil = new $UncompressClass $filename, - -Strict => 1, - -Append => 1 - ; - - my $data = ''; - $data = $init if defined $init ; - 1 while $fil->read($data) > 0; - - $fil->close ; - return $data ; -} - - -{ - - title "Testing $CompressClass Errors"; - - my $buffer ; - - for my $value (undef, -1, 'fred') - { - my $stringValue = defined $value ? $value : 'undef'; - title "BlockSize100K => $stringValue"; - my $err = "Parameter 'BlockSize100K' must be an unsigned int, got '$stringValue'"; - my $bz ; - eval { $bz = new IO::Compress::Bzip2(\$buffer, BlockSize100K => $value) }; - like $@, mkErr("IO::Compress::Bzip2: $err"), - " value $stringValue is bad"; - is $Bzip2Error, "IO::Compress::Bzip2: $err", - " value $stringValue is bad"; - ok ! $bz, " no bz object"; - } - - for my $value (0, 10, 99999) - { - my $stringValue = defined $value ? $value : 'undef'; - title "BlockSize100K => $stringValue"; - my $err = "Parameter 'BlockSize100K' not between 1 and 9, got $stringValue"; - my $bz ; - eval { $bz = new IO::Compress::Bzip2(\$buffer, BlockSize100K => $value) }; - like $@, mkErr("IO::Compress::Bzip2: $err"), - " value $stringValue is bad"; - is $Bzip2Error, "IO::Compress::Bzip2: $err", - " value $stringValue is bad"; - ok ! $bz, " no bz object"; - } - - for my $value (undef, -1, 'fred') - { - my $stringValue = defined $value ? $value : 'undef'; - title "WorkFactor => $stringValue"; - my $err = "Parameter 'WorkFactor' must be an unsigned int, got '$stringValue'"; - my $bz ; - eval { $bz = new IO::Compress::Bzip2(\$buffer, WorkFactor => $value) }; - like $@, mkErr("IO::Compress::Bzip2: $err"), - " value $stringValue is bad"; - is $Bzip2Error, "IO::Compress::Bzip2: $err", - " value $stringValue is bad"; - ok ! $bz, " no bz object"; - } - - for my $value (251, 99999) - { - my $stringValue = defined $value ? $value : 'undef'; - title "WorkFactor => $stringValue"; - my $err = "Parameter 'WorkFactor' not between 0 and 250, got $stringValue"; - my $bz ; - eval { $bz = new IO::Compress::Bzip2(\$buffer, WorkFactor => $value) }; - like $@, mkErr("IO::Compress::Bzip2: $err"), - " value $stringValue is bad"; - is $Bzip2Error, "IO::Compress::Bzip2: $err", - " value $stringValue is bad"; - ok ! $bz, " no bz object"; - } - -} - - -{ - title "Testing $UncompressClass Errors"; - - my $buffer ; - - for my $value (-1, 'fred') - { - my $stringValue = defined $value ? $value : 'undef'; - title "Small => $stringValue"; - my $err = "Parameter 'Small' must be an int, got '$stringValue'"; - my $bz ; - eval { $bz = new IO::Uncompress::Bunzip2(\$buffer, Small => $value) }; - like $@, mkErr("IO::Uncompress::Bunzip2: $err"), - " value $stringValue is bad"; - is $Bunzip2Error, "IO::Uncompress::Bunzip2: $err", - " value $stringValue is bad"; - ok ! $bz, " no bz object"; - } - -} - -{ - title "Testing $CompressClass and $UncompressClass"; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - for my $value ( 1 .. 9 ) - { - title "$CompressClass - BlockSize100K => $value"; - my $lex = new LexFile my $name ; - my $bz ; - $bz = new IO::Compress::Bzip2($name, BlockSize100K => $value) - or diag $IO::Compress::Bzip2::Bzip2Error ; - ok $bz, " bz object ok"; - $bz->write($hello); - $bz->close($hello); - - is myBZreadFile($name), $hello, " got expected content"; - } - - for my $value ( 0 .. 250 ) - { - title "$CompressClass - WorkFactor => $value"; - my $lex = new LexFile my $name ; - my $bz ; - $bz = new IO::Compress::Bzip2($name, WorkFactor => $value); - ok $bz, " bz object ok"; - $bz->write($hello); - $bz->close($hello); - - is myBZreadFile($name), $hello, " got expected content"; - } - - for my $value ( 0 .. 1 ) - { - title "$UncompressClass - Small => $value"; - my $lex = new LexFile my $name ; - my $bz ; - $bz = new IO::Compress::Bzip2($name); - ok $bz, " bz object ok"; - $bz->write($hello); - $bz->close($hello); - - my $fil = new $UncompressClass $name, - Append => 1, - Small => $value ; - - my $data = ''; - 1 while $fil->read($data) > 0; - - $fil->close ; - - is $data, $hello, " got expected"; - } -} - - -1; - - - - diff --git a/ext/IO-Compress/t/001zlib-generic-deflate.t b/ext/IO-Compress/t/001zlib-generic-deflate.t deleted file mode 100644 index a988ab9791..0000000000 --- a/ext/IO-Compress/t/001zlib-generic-deflate.t +++ /dev/null @@ -1,20 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "zlib-generic.pl" ; diff --git a/ext/IO-Compress/t/001zlib-generic-gzip.t b/ext/IO-Compress/t/001zlib-generic-gzip.t deleted file mode 100644 index db9101d91f..0000000000 --- a/ext/IO-Compress/t/001zlib-generic-gzip.t +++ /dev/null @@ -1,20 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "zlib-generic.pl" ; diff --git a/ext/IO-Compress/t/001zlib-generic-rawdeflate.t b/ext/IO-Compress/t/001zlib-generic-rawdeflate.t deleted file mode 100644 index 4c491eb3a2..0000000000 --- a/ext/IO-Compress/t/001zlib-generic-rawdeflate.t +++ /dev/null @@ -1,20 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "zlib-generic.pl" ; diff --git a/ext/IO-Compress/t/001zlib-generic-zip.t b/ext/IO-Compress/t/001zlib-generic-zip.t deleted file mode 100644 index a9c755537f..0000000000 --- a/ext/IO-Compress/t/001zlib-generic-zip.t +++ /dev/null @@ -1,20 +0,0 @@ -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 IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "zlib-generic.pl" ; diff --git a/ext/IO-Compress/t/002any-deflate.t b/ext/IO-Compress/t/002any-deflate.t deleted file mode 100644 index 6a4387ef0c..0000000000 --- a/ext/IO-Compress/t/002any-deflate.t +++ /dev/null @@ -1,29 +0,0 @@ -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 IO::Uncompress::AnyInflate qw($AnyInflateError) ; - -use IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub getClass -{ - 'AnyInflate'; -} - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "any.pl" ; -run(); diff --git a/ext/IO-Compress/t/002any-gzip.t b/ext/IO-Compress/t/002any-gzip.t deleted file mode 100644 index e93625fdfa..0000000000 --- a/ext/IO-Compress/t/002any-gzip.t +++ /dev/null @@ -1,29 +0,0 @@ -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 IO::Uncompress::AnyInflate qw($AnyInflateError) ; - -use IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub getClass -{ - 'AnyInflate'; -} - - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "any.pl" ; -run(); diff --git a/ext/IO-Compress/t/002any-rawdeflate.t b/ext/IO-Compress/t/002any-rawdeflate.t deleted file mode 100644 index ef716c60c1..0000000000 --- a/ext/IO-Compress/t/002any-rawdeflate.t +++ /dev/null @@ -1,28 +0,0 @@ -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 IO::Uncompress::AnyInflate qw($AnyInflateError) ; -use IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub getClass -{ - 'AnyInflate'; -} - - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "any.pl" ; -run(); diff --git a/ext/IO-Compress/t/002any-transparent.t b/ext/IO-Compress/t/002any-transparent.t deleted file mode 100644 index bb26bbcac0..0000000000 --- a/ext/IO-Compress/t/002any-transparent.t +++ /dev/null @@ -1,72 +0,0 @@ -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 => 15 + $extra ; - - use_ok('IO::Uncompress::AnyInflate', qw($AnyInflateError)) ; - -} - -{ - - my $string = <<EOM; -This is not compressed data -EOM - - my $buffer = $string ; - - for my $file (0, 1) - { - title "AnyInflate with Non-compressed data (File $file)" ; - - my $lex = new LexFile my $output; - my $input ; - - if ($file) { - writeFile($output, $buffer); - $input = $output; - } - else { - $input = \$buffer; - } - - - my $unc ; - my $keep = $buffer ; - $unc = new IO::Uncompress::AnyInflate $input, -Transparent => 0 ; - ok ! $unc," no AnyInflate object when -Transparent => 0" ; - is $buffer, $keep ; - - $buffer = $keep ; - $unc = new IO::Uncompress::AnyInflate \$buffer, -Transparent => 1 ; - ok $unc, " AnyInflate object when -Transparent => 1" ; - - my $uncomp ; - ok $unc->read($uncomp) > 0 ; - ok $unc->eof() ; - #ok $unc->type eq $Type; - - is $uncomp, $string ; - } -} - -1; diff --git a/ext/IO-Compress/t/002any-zip.t b/ext/IO-Compress/t/002any-zip.t deleted file mode 100644 index 27f1714899..0000000000 --- a/ext/IO-Compress/t/002any-zip.t +++ /dev/null @@ -1,29 +0,0 @@ -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 IO::Uncompress::AnyInflate qw($AnyInflateError) ; - -use IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub getClass -{ - 'AnyInflate'; -} - - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "any.pl" ; -run(); diff --git a/ext/IO-Compress/t/004gziphdr.t b/ext/IO-Compress/t/004gziphdr.t deleted file mode 100644 index 210d499a65..0000000000 --- a/ext/IO-Compress/t/004gziphdr.t +++ /dev/null @@ -1,962 +0,0 @@ -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 => 910 + $extra ; - - use_ok('Compress::Raw::Zlib') ; - use_ok('IO::Compress::Gzip::Constants') ; - - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - -} - - - -# Check the Gzip Header Parameters -#======================================== - -my $ThisOS_code = $Compress::Raw::Zlib::gzip_os_code; - -my $lex = new LexFile my $name ; - -{ - title "Check Defaults"; - # Check Name defaults undef, no name, no comment - # and Time can be explicitly set. - - my $hdr = readHeaderInfo($name, -Time => 1234); - - is $hdr->{Time}, 1234; - ok ! defined $hdr->{Name}; - is $hdr->{MethodName}, 'Deflated'; - is $hdr->{ExtraFlags}, 0; - is $hdr->{MethodID}, Z_DEFLATED; - is $hdr->{OsID}, $ThisOS_code ; - ok ! defined $hdr->{Comment} ; - ok ! defined $hdr->{ExtraFieldRaw} ; - ok ! defined $hdr->{HeaderCRC} ; - ok ! $hdr->{isMinimalHeader} ; -} - -{ - - title "Check name can be different from filename" ; - # Check Name can be different from filename - # Comment and Extra can be set - # Can specify a zero Time - - my $comment = "This is a Comment" ; - my $extra = "A little something extra" ; - my $aname = "a new name" ; - my $hdr = readHeaderInfo $name, - -Strict => 0, - -Name => $aname, - -Comment => $comment, - -ExtraField => $extra, - -Time => 0 ; - - ok $hdr->{Time} == 0; - ok $hdr->{Name} eq $aname; - ok $hdr->{MethodName} eq 'Deflated'; - ok $hdr->{MethodID} == 8; - is $hdr->{ExtraFlags}, 0; - ok $hdr->{Comment} eq $comment ; - is $hdr->{OsID}, $ThisOS_code ; - ok ! $hdr->{isMinimalHeader} ; - ok ! defined $hdr->{HeaderCRC} ; -} - -{ - title "Check Time defaults to now" ; - - # Check Time defaults to now - # and that can have empty name, comment and extrafield - my $before = time ; - my $hdr = readHeaderInfo $name, - -TextFlag => 1, - -Name => "", - -Comment => "", - -ExtraField => ""; - my $after = time ; - - ok $hdr->{Time} >= $before ; - ok $hdr->{Time} <= $after ; - - ok defined $hdr->{Name} ; - ok $hdr->{Name} eq ""; - ok defined $hdr->{Comment} ; - ok $hdr->{Comment} eq ""; - ok defined $hdr->{ExtraFieldRaw} ; - ok $hdr->{ExtraFieldRaw} eq ""; - is $hdr->{ExtraFlags}, 0; - - ok ! $hdr->{isMinimalHeader} ; - ok $hdr->{TextFlag} ; - ok ! defined $hdr->{HeaderCRC} ; - is $hdr->{OsID}, $ThisOS_code ; - -} - -{ - title "can have null extrafield" ; - - my $before = time ; - my $hdr = readHeaderInfo $name, - -strict => 0, - -Name => "a", - -Comment => "b", - -ExtraField => "\x00"; - my $after = time ; - - ok $hdr->{Time} >= $before ; - ok $hdr->{Time} <= $after ; - ok $hdr->{Name} eq "a"; - ok $hdr->{Comment} eq "b"; - is $hdr->{ExtraFlags}, 0; - ok $hdr->{ExtraFieldRaw} eq "\x00"; - ok ! $hdr->{isMinimalHeader} ; - ok ! $hdr->{TextFlag} ; - ok ! defined $hdr->{HeaderCRC} ; - is $hdr->{OsID}, $ThisOS_code ; - -} - -{ - title "can have undef name, comment, time and extrafield" ; - - my $hdr = readHeaderInfo $name, - -Name => undef, - -Comment => undef, - -ExtraField => undef, - -Time => undef; - - ok $hdr->{Time} == 0; - ok ! defined $hdr->{Name} ; - ok ! defined $hdr->{Comment} ; - ok ! defined $hdr->{ExtraFieldRaw} ; - ok ! $hdr->{isMinimalHeader} ; - ok ! $hdr->{TextFlag} ; - ok ! defined $hdr->{HeaderCRC} ; - is $hdr->{OsID}, $ThisOS_code ; - -} - -for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") -{ - title "Comment with $value" ; - - my $v = pack "h*", $value; - my $comment = "my${v}comment$v"; - my $hdr = readHeaderInfo $name, - Time => 0, - -TextFlag => 1, - -Name => "", - -Comment => $comment, - -ExtraField => ""; - my $after = time ; - - is $hdr->{Time}, 0 ; - - ok defined $hdr->{Name} ; - ok $hdr->{Name} eq ""; - ok defined $hdr->{Comment} ; - is $hdr->{Comment}, $comment; - ok defined $hdr->{ExtraFieldRaw} ; - ok $hdr->{ExtraFieldRaw} eq ""; - is $hdr->{ExtraFlags}, 0; - - ok ! $hdr->{isMinimalHeader} ; - ok $hdr->{TextFlag} ; - ok ! defined $hdr->{HeaderCRC} ; - is $hdr->{OsID}, $ThisOS_code ; -} - -{ - title "Check crchdr" ; - - my $hdr = readHeaderInfo $name, -HeaderCRC => 1; - - ok ! defined $hdr->{Name}; - is $hdr->{ExtraFlags}, 0; - ok ! defined $hdr->{ExtraFieldRaw} ; - ok ! defined $hdr->{Comment} ; - ok ! $hdr->{isMinimalHeader} ; - ok ! $hdr->{TextFlag} ; - ok defined $hdr->{HeaderCRC} ; - is $hdr->{OsID}, $ThisOS_code ; -} - -{ - title "Check ExtraFlags" ; - - my $hdr = readHeaderInfo $name, -Level => Z_BEST_SPEED; - - ok ! defined $hdr->{Name}; - is $hdr->{ExtraFlags}, 2; - ok ! defined $hdr->{ExtraFieldRaw} ; - ok ! defined $hdr->{Comment} ; - ok ! $hdr->{isMinimalHeader} ; - ok ! $hdr->{TextFlag} ; - ok ! defined $hdr->{HeaderCRC} ; - - $hdr = readHeaderInfo $name, -Level => Z_BEST_COMPRESSION; - - ok ! defined $hdr->{Name}; - is $hdr->{ExtraFlags}, 4; - ok ! defined $hdr->{ExtraFieldRaw} ; - ok ! defined $hdr->{Comment} ; - ok ! $hdr->{isMinimalHeader} ; - ok ! $hdr->{TextFlag} ; - ok ! defined $hdr->{HeaderCRC} ; - - $hdr = readHeaderInfo $name, -Level => Z_BEST_COMPRESSION, - -ExtraFlags => 42; - - ok ! defined $hdr->{Name}; - is $hdr->{ExtraFlags}, 42; - ok ! defined $hdr->{ExtraFieldRaw} ; - ok ! defined $hdr->{Comment} ; - ok ! $hdr->{isMinimalHeader} ; - ok ! $hdr->{TextFlag} ; - ok ! defined $hdr->{HeaderCRC} ; - - -} - -{ - title "OS Code" ; - - for my $code ( -1, undef, '', 'fred' ) - { - my $code_name = defined $code ? "'$code'" : "'undef'"; - eval { new IO::Compress::Gzip $name, -OS_Code => $code } ; - like $@, mkErr("^IO::Compress::Gzip: Parameter 'OS_Code' must be an unsigned int, got $code_name"), - " Trap OS Code $code_name"; - } - - for my $code ( qw( 256 ) ) - { - eval { ok ! new IO::Compress::Gzip($name, OS_Code => $code) }; - like $@, mkErr("OS_Code must be between 0 and 255, got '$code'"), - " Trap OS Code $code"; - like $GzipError, "/OS_Code must be between 0 and 255, got '$code'/", - " Trap OS Code $code"; - } - - for my $code ( qw(0 1 12 254 255) ) - { - my $hdr = readHeaderInfo $name, OS_Code => $code; - - is $hdr->{OsID}, $code, " Code is $code" ; - } - - - -} - -{ - title 'Check ExtraField'; - - my @tests = ( - [1, ['AB' => ''] => [['AB'=>'']] ], - [1, {'AB' => ''} => [['AB'=>'']] ], - [1, ['AB' => 'Fred'] => [['AB'=>'Fred']] ], - [1, {'AB' => 'Fred'} => [['AB'=>'Fred']] ], - [1, ['Xx' => '','AB' => 'Fred'] => [['Xx' => ''],['AB'=>'Fred']] ], - [1, ['Xx' => '','Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred']] ], - [1, ['Xx' => '', - 'Xx' => 'Fred', - 'Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred'], - ['Xx'=>'Fred']] ], - [1, [ ['Xx' => 'a'], - ['AB' => 'Fred'] ] => [['Xx' => 'a'],['AB'=>'Fred']] ], - [0, {'AB' => 'Fred', - 'Pq' => 'r', - "\x01\x02" => "\x03"} => [['AB'=>'Fred'], - ['Pq'=>'r'], - ["\x01\x02"=>"\x03"]] ], - [1, ['AB' => 'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE] => - [['AB'=>'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE]] ], - ); - - foreach my $test (@tests) { - my ($order, $input, $result) = @$test ; - ok my $x = new IO::Compress::Gzip $name, - -ExtraField => $input, - -HeaderCRC => 1 - or diag "GzipError is $GzipError" ; ; - my $string = "abcd" ; - ok $x->write($string) ; - ok $x->close ; - #is GZreadFile($name), $string ; - - ok $x = new IO::Uncompress::Gunzip $name, - #-Strict => 1, - -ParseExtra => 1 - or diag "GunzipError is $GunzipError" ; ; - my $hdr = $x->getHeaderInfo(); - ok $hdr; - ok ! defined $hdr->{Name}; - ok ! defined $hdr->{Comment} ; - ok ! $hdr->{isMinimalHeader} ; - ok ! $hdr->{TextFlag} ; - ok defined $hdr->{HeaderCRC} ; - - ok defined $hdr->{ExtraFieldRaw} ; - ok defined $hdr->{ExtraField} ; - - my $extra = $hdr->{ExtraField} ; - - if ($order) { - eq_array $extra, $result; - } else { - eq_set $extra, $result; - } - } - -} - -{ - title 'Write Invalid ExtraField'; - - my $prefix = 'Error with ExtraField Parameter: '; - my @tests = ( - [ sub{ "abc" } => "Not a scalar, array ref or hash ref"], - [ [ "a" ] => "Not even number of elements"], - [ [ "a" => "fred" ] => 'SubField ID not two chars long'], - [ [ "a\x00" => "fred" ] => 'SubField ID 2nd byte is 0x00'], - [ [ [ {}, "abc" ]] => "SubField ID is a reference"], - [ [ [ "ab", \1 ]] => "SubField Data is a reference"], - [ [ {"a" => "fred"} ] => "Not list of lists"], - [ [ ['ab'=>'x'],{"a" => "fred"} ] => "Not list of lists"], - [ [ ["aa"] ] => "SubField must have two parts"], - [ [ ["aa", "b", "c"] ] => "SubField must have two parts"], - [ [ ["ab" => 'x' x (GZIP_FEXTRA_SUBFIELD_MAX_SIZE + 1) ] ] - => "SubField Data too long"], - - [ { 'abc', 1 } => "SubField ID not two chars long"], - [ { \1 , "abc" } => "SubField ID not two chars long"], - [ { "ab", \1 } => "SubField Data is a reference"], - ); - - - - foreach my $test (@tests) { - my ($input, $string) = @$test ; - my $buffer ; - my $x ; - eval { $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input; }; - like $@, mkErr("$prefix$string"); - like $GzipError, "/$prefix$string/"; - ok ! $x ; - - } - -} - -{ - # Corrupt ExtraField - - my @tests = ( - ["Sub-field truncated", - "Error with ExtraField Parameter: Truncated in FEXTRA Body Section", - "Header Error: Truncated in FEXTRA Body Section", - ['a', undef, undef] ], - ["Length of field incorrect", - "Error with ExtraField Parameter: Truncated in FEXTRA Body Section", - "Header Error: Truncated in FEXTRA Body Section", - ["ab", 255, "abc"] ], - ["Length of 2nd field incorrect", - "Error with ExtraField Parameter: Truncated in FEXTRA Body Section", - "Header Error: Truncated in FEXTRA Body Section", - ["ab", 3, "abc"], ["de", 7, "x"] ], - ["Length of 2nd field incorrect", - "Error with ExtraField Parameter: SubField ID 2nd byte is 0x00", - "Header Error: SubField ID 2nd byte is 0x00", - ["a\x00", 3, "abc"], ["de", 7, "x"] ], - ); - - foreach my $test (@tests) - { - my $name = shift @$test; - my $gzip_error = shift @$test; - my $gunzip_error = shift @$test; - - title "Read Corrupt ExtraField - $name" ; - - my $input = ''; - - for my $field (@$test) - { - my ($id, $len, $data) = @$field; - - $input .= $id if defined $id ; - $input .= pack("v", $len) if defined $len ; - $input .= $data if defined $data; - } - #hexDump(\$input); - - my $buffer ; - my $x ; - eval {$x = new IO::Compress::Gzip \$buffer, -ExtraField => $input, Strict => 1; }; - like $@, mkErr("$gzip_error"), " $name"; - like $GzipError, "/$gzip_error/", " $name"; - - ok ! $x, " IO::Compress::Gzip fails"; - like $GzipError, "/$gzip_error/", " $name"; - - foreach my $check (0, 1) - { - ok $x = new IO::Compress::Gzip \$buffer, - ExtraField => $input, - Strict => 0 - or diag "GzipError is $GzipError" ; - my $string = "abcd" ; - $x->write($string) ; - $x->close ; - is anyUncompress(\$buffer), $string ; - - $x = new IO::Uncompress::Gunzip \$buffer, - Strict => 0, - Transparent => 0, - ParseExtra => $check; - if ($check) { - ok ! $x ; - like $GunzipError, "/^$gunzip_error/"; - } - else { - ok $x ; - } - - } - } -} - - -{ - title 'Check Minimal'; - - ok my $x = new IO::Compress::Gzip $name, -Minimal => 1; - my $string = "abcd" ; - ok $x->write($string) ; - ok $x->close ; - #is GZreadFile($name), $string ; - - ok $x = new IO::Uncompress::Gunzip $name ; - my $hdr = $x->getHeaderInfo(); - ok $hdr; - ok $hdr->{Time} == 0; - is $hdr->{ExtraFlags}, 0; - ok ! defined $hdr->{Name} ; - ok ! defined $hdr->{ExtraFieldRaw} ; - ok ! defined $hdr->{Comment} ; - is $hdr->{OsName}, 'Unknown' ; - is $hdr->{MethodName}, "Deflated"; - is $hdr->{Flags}, 0; - ok $hdr->{isMinimalHeader} ; - ok ! $hdr->{TextFlag} ; - ok $x->close ; -} - -{ - # Check Minimal + no comressed data - # This is the smallest possible gzip file (20 bytes) - - ok my $x = new IO::Compress::Gzip $name, -Minimal => 1; - ok $x->close ; - #ok GZreadFile($name) eq '' ; - - ok $x = new IO::Uncompress::Gunzip $name, -Append => 1 ; - my $data ; - my $status = 1; - - $status = $x->read($data) - while $status > 0; - is $status, 0 ; - is $data, ''; - ok ! $x->error() ; - ok $x->eof() ; - - my $hdr = $x->getHeaderInfo(); - ok $hdr; - - ok defined $hdr->{ISIZE} ; - is $hdr->{ISIZE}, 0; - - ok defined $hdr->{CRC32} ; - is $hdr->{CRC32}, 0; - - is $hdr->{Time}, 0; - ok ! defined $hdr->{Name} ; - ok ! defined $hdr->{ExtraFieldRaw} ; - ok ! defined $hdr->{Comment} ; - is $hdr->{OsName}, 'Unknown' ; - is $hdr->{MethodName}, "Deflated"; - is $hdr->{Flags}, 0; - ok $hdr->{isMinimalHeader} ; - ok ! $hdr->{TextFlag} ; - ok $x->close ; -} - -{ - # Header Corruption Tests - - my $string = <<EOM; -some text -EOM - - my $good = ''; - ok my $x = new IO::Compress::Gzip \$good, -HeaderCRC => 1 ; - ok $x->write($string) ; - ok $x->close ; - - { - title "Header Corruption - Fingerprint wrong 1st byte" ; - my $buffer = $good ; - substr($buffer, 0, 1) = 'x' ; - - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; - ok $GunzipError =~ /Header Error: Bad Magic/; - } - - { - title "Header Corruption - Fingerprint wrong 2nd byte" ; - my $buffer = $good ; - substr($buffer, 1, 1) = "\xFF" ; - - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; - ok $GunzipError =~ /Header Error: Bad Magic/; - #print "$GunzipError\n"; - } - - { - title "Header Corruption - CM not 8"; - my $buffer = $good ; - substr($buffer, 2, 1) = 'x' ; - - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; - like $GunzipError, '/Header Error: Not Deflate \(CM is \d+\)/'; - } - - { - title "Header Corruption - Use of Reserved Flags"; - my $buffer = $good ; - substr($buffer, 3, 1) = "\xff"; - - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; - like $GunzipError, '/Header Error: Use of Reserved Bits in FLG field./'; - } - - { - title "Header Corruption - Fail HeaderCRC"; - my $buffer = $good ; - substr($buffer, 10, 1) = chr((ord(substr($buffer, 10, 1)) + 1) & 0xFF); - - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0, Strict => 1 - or print "# $GunzipError\n"; - like $GunzipError, '/Header Error: CRC16 mismatch/' - #or diag "buffer length " . length($buffer); - or hexDump(\$good), hexDump(\$buffer); - } -} - -{ - title "ExtraField max raw size"; - my $x ; - my $store = "x" x GZIP_FEXTRA_MAX_SIZE ; - my $z = new IO::Compress::Gzip(\$x, ExtraField => $store, Strict => 0) ; - ok $z, "Created IO::Compress::Gzip object" ; - my $gunz = new IO::Uncompress::Gunzip \$x, Strict => 0; - ok $gunz, "Created IO::Uncompress::Gunzip object" ; - my $hdr = $gunz->getHeaderInfo(); - ok $hdr; - - is $hdr->{ExtraFieldRaw}, $store ; -} - -{ - title "Header Corruption - ExtraField too big"; - my $x; - eval { new IO::Compress::Gzip(\$x, -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ;}; - like $@, mkErr('Error with ExtraField Parameter: Too Large'); - like $GzipError, '/Error with ExtraField Parameter: Too Large/'; -} - -{ - title "Header Corruption - Create Name with Illegal Chars"; - - my $x; - eval { new IO::Compress::Gzip \$x, -Name => "fred\x02" }; - like $@, mkErr('Non ISO 8859-1 Character found in Name'); - like $GzipError, '/Non ISO 8859-1 Character found in Name/'; - - ok my $gz = new IO::Compress::Gzip \$x, - -Strict => 0, - -Name => "fred\x02" ; - ok $gz->close(); - - ok ! new IO::Uncompress::Gunzip \$x, - -Transparent => 0, - -Strict => 1; - - like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Name/'; - ok my $gunzip = new IO::Uncompress::Gunzip \$x, - -Strict => 0; - - my $hdr = $gunzip->getHeaderInfo() ; - - is $hdr->{Name}, "fred\x02"; - -} - -{ - title "Header Corruption - Null Chars in Name"; - my $x; - eval { new IO::Compress::Gzip \$x, -Name => "\x00" }; - like $@, mkErr('Null Character found in Name'); - like $GzipError, '/Null Character found in Name/'; - - eval { new IO::Compress::Gzip \$x, -Name => "abc\x00" }; - like $@, mkErr('Null Character found in Name'); - like $GzipError, '/Null Character found in Name/'; - - ok my $gz = new IO::Compress::Gzip \$x, - -Strict => 0, - -Name => "abc\x00de" ; - ok $gz->close() ; - ok my $gunzip = new IO::Uncompress::Gunzip \$x, - -Strict => 0; - - my $hdr = $gunzip->getHeaderInfo() ; - - is $hdr->{Name}, "abc"; - -} - -{ - title "Header Corruption - Create Comment with Illegal Chars"; - - my $x; - eval { new IO::Compress::Gzip \$x, -Comment => "fred\x02" }; - like $@, mkErr('Non ISO 8859-1 Character found in Comment'); - like $GzipError, '/Non ISO 8859-1 Character found in Comment/'; - - ok my $gz = new IO::Compress::Gzip \$x, - -Strict => 0, - -Comment => "fred\x02" ; - ok $gz->close(); - - ok ! new IO::Uncompress::Gunzip \$x, Strict => 1, - -Transparent => 0; - - like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Comment/'; - ok my $gunzip = new IO::Uncompress::Gunzip \$x, Strict => 0; - - my $hdr = $gunzip->getHeaderInfo() ; - - is $hdr->{Comment}, "fred\x02"; - -} - -{ - title "Header Corruption - Null Char in Comment"; - my $x; - eval { new IO::Compress::Gzip \$x, -Comment => "\x00" }; - like $@, mkErr('Null Character found in Comment'); - like $GzipError, '/Null Character found in Comment/'; - - eval { new IO::Compress::Gzip \$x, -Comment => "abc\x00" } ; - like $@, mkErr('Null Character found in Comment'); - like $GzipError, '/Null Character found in Comment/'; - - ok my $gz = new IO::Compress::Gzip \$x, - -Strict => 0, - -Comment => "abc\x00de" ; - ok $gz->close() ; - ok my $gunzip = new IO::Uncompress::Gunzip \$x, - -Strict => 0; - - my $hdr = $gunzip->getHeaderInfo() ; - - is $hdr->{Comment}, "abc"; - -} - - -for my $index ( GZIP_MIN_HEADER_SIZE + 1 .. GZIP_MIN_HEADER_SIZE + GZIP_FEXTRA_HEADER_SIZE + 1) -{ - title "Header Corruption - Truncated in Extra"; - my $string = <<EOM; -some text -EOM - - my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1, Strict => 0, - -ExtraField => "hello" x 10 ; - ok $x->write($string) ; - ok $x->close ; - - substr($truncated, $index) = '' ; - #my $lex = new LexFile my $name ; - #writeFile($name, $truncated) ; - - #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; - my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; - ok ! $g - or print "# $g\n" ; - - like($GunzipError, '/^Header Error: Truncated in FEXTRA/'); - - -} - -my $Name = "fred" ; - my $truncated ; -for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Name) -1) -{ - title "Header Corruption - Truncated in Name"; - my $string = <<EOM; -some text -EOM - - my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -Name => $Name; - ok $x->write($string) ; - ok $x->close ; - - substr($truncated, $index) = '' ; - - my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; - ok ! $g - or print "# $g\n" ; - - like $GunzipError, '/^Header Error: Truncated in FNAME Section/'; - -} - -my $Comment = "comment" ; -for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Comment) -1) -{ - title "Header Corruption - Truncated in Comment"; - my $string = <<EOM; -some text -EOM - - my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -Comment => $Comment; - ok $x->write($string) ; - ok $x->close ; - - substr($truncated, $index) = '' ; - #my $lex = new LexFile my $name ; - #writeFile($name, $truncated) ; - - #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; - my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; - ok ! $g - or print "# $g\n" ; - - like $GunzipError, '/^Header Error: Truncated in FCOMMENT Section/'; - -} - -for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + GZIP_FHCRC_SIZE -1) -{ - title "Header Corruption - Truncated in CRC"; - my $string = <<EOM; -some text -EOM - - my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1; - ok $x->write($string) ; - ok $x->close ; - - substr($truncated, $index) = '' ; - my $lex = new LexFile my $name ; - writeFile($name, $truncated) ; - - my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; - #my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; - ok ! $g - or print "# $g\n" ; - - like $GunzipError, '/^Header Error: Truncated in FHCRC Section/'; - -} - - -{ - # Trailer Corruption tests - - my $string = <<EOM; -some text -EOM - - my $good ; - { - ok my $x = new IO::Compress::Gzip \$good ; - ok $x->write($string) ; - ok $x->close ; - } - - writeFile($name, $good) ; - ok my $gunz = new IO::Uncompress::Gunzip $name, - -Append => 1, - -Strict => 1; - my $uncomp ; - 1 while $gunz->read($uncomp) > 0 ; - ok $gunz->close() ; - ok $uncomp eq $string - or print "# got [$uncomp] wanted [$string]\n";; - - foreach my $trim (-8 .. -1) - { - my $got = $trim + 8 ; - title "Trailer Corruption - Trailer truncated to $got bytes" ; - my $buffer = $good ; - my $expected_trailing = substr($good, -8, 8) ; - substr($expected_trailing, $trim) = ''; - - substr($buffer, $trim) = ''; - writeFile($name, $buffer) ; - - foreach my $strict (0, 1) - { - ok my $gunz = new IO::Uncompress::Gunzip $name, -Strict => $strict ; - my $uncomp ; - if ($strict) - { - ok $gunz->read($uncomp) < 0 ; - like $GunzipError, "/Trailer Error: trailer truncated. Expected 8 bytes, got $got/"; - } - else - { - ok $gunz->read($uncomp) > 0 ; - ok ! $GunzipError ; - my $expected = substr($buffer, - $got); - is $gunz->trailingData(), $expected_trailing; - } - ok $gunz->eof() ; - ok $uncomp eq $string; - ok $gunz->close ; - } - - } - - { - title "Trailer Corruption - Length Wrong, CRC Correct" ; - my $buffer = $good ; - my $actual_len = unpack("V", substr($buffer, -4, 4)); - substr($buffer, -4, 4) = pack('V', $actual_len + 1); - writeFile($name, $buffer) ; - - foreach my $strict (0, 1) - { - ok my $gunz = new IO::Uncompress::Gunzip $name, - -Strict => $strict ; - my $uncomp ; - if ($strict) - { - ok $gunz->read($uncomp) < 0 ; - my $got_len = $actual_len + 1; - like $GunzipError, "/Trailer Error: ISIZE mismatch. Got $got_len, expected $actual_len/"; - } - else - { - ok $gunz->read($uncomp) > 0 ; - ok ! $GunzipError ; - #is $gunz->trailingData(), substr($buffer, - $got) ; - } - ok ! $gunz->trailingData() ; - ok $gunz->eof() ; - ok $uncomp eq $string; - ok $gunz->close ; - } - - } - - { - title "Trailer Corruption - Length Correct, CRC Wrong" ; - my $buffer = $good ; - my $actual_crc = unpack("V", substr($buffer, -8, 4)); - substr($buffer, -8, 4) = pack('V', $actual_crc+1); - writeFile($name, $buffer) ; - - foreach my $strict (0, 1) - { - ok my $gunz = new IO::Uncompress::Gunzip $name, - -Strict => $strict ; - my $uncomp ; - if ($strict) - { - ok $gunz->read($uncomp) < 0 ; - like $GunzipError, '/Trailer Error: CRC mismatch/'; - } - else - { - ok $gunz->read($uncomp) > 0 ; - ok ! $GunzipError ; - } - ok ! $gunz->trailingData() ; - ok $gunz->eof() ; - ok $uncomp eq $string; - ok $gunz->close ; - } - - } - - { - title "Trailer Corruption - Length Wrong, CRC Wrong" ; - my $buffer = $good ; - my $actual_len = unpack("V", substr($buffer, -4, 4)); - my $actual_crc = unpack("V", substr($buffer, -8, 4)); - substr($buffer, -4, 4) = pack('V', $actual_len+1); - substr($buffer, -8, 4) = pack('V', $actual_crc+1); - writeFile($name, $buffer) ; - - foreach my $strict (0, 1) - { - ok my $gunz = new IO::Uncompress::Gunzip $name, - -Strict => $strict ; - my $uncomp ; - if ($strict) - { - ok $gunz->read($uncomp) < 0 ; - like $GunzipError, '/Trailer Error: CRC mismatch/'; - } - else - { - ok $gunz->read($uncomp) > 0 ; - ok ! $GunzipError ; - } - ok $gunz->eof() ; - ok $uncomp eq $string; - ok $gunz->close ; - } - - } -} - - - diff --git a/ext/IO-Compress/t/005defhdr.t b/ext/IO-Compress/t/005defhdr.t deleted file mode 100644 index 990b79b3f1..0000000000 --- a/ext/IO-Compress/t/005defhdr.t +++ /dev/null @@ -1,349 +0,0 @@ -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 => 595 + $extra ; - - use_ok('Compress::Raw::Zlib') ; - - use_ok('IO::Compress::Deflate', qw($DeflateError)) ; - use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; - - use_ok('IO::Compress::Zlib::Constants'); - -} - - -sub ReadHeaderInfo -{ - my $string = shift || '' ; - my %opts = @_ ; - - my $buffer ; - ok my $def = new IO::Compress::Deflate \$buffer, %opts ; - is $def->write($string), length($string) ; - ok $def->close ; - #print "ReadHeaderInfo\n"; hexDump(\$buffer); - - ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1 ; - my $uncomp ; - #ok $inf->read($uncomp) ; - my $actual = 0 ; - my $status = 1 ; - while (($status = $inf->read($uncomp)) > 0) { - $actual += $status ; - } - - is $actual, length($string) ; - is $uncomp, $string; - ok ! $inf->error() ; - ok $inf->eof() ; - ok my $hdr = $inf->getHeaderInfo(); - ok $inf->close ; - - return $hdr ; -} - -sub ReadHeaderInfoZlib -{ - my $string = shift || '' ; - my %opts = @_ ; - - my $buffer ; - ok my $def = new Compress::Raw::Zlib::Deflate AppendOutput => 1, %opts ; - cmp_ok $def->deflate($string, $buffer), '==', Z_OK; - cmp_ok $def->flush($buffer), '==', Z_OK; - #print "ReadHeaderInfoZlib\n"; hexDump(\$buffer); - - ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1 ; - my $uncomp ; - #ok $inf->read($uncomp) ; - my $actual = 0 ; - my $status = 1 ; - while (($status = $inf->read($uncomp)) > 0) { - $actual += $status ; - } - - is $actual, length($string) ; - is $uncomp, $string; - ok ! $inf->error() ; - ok $inf->eof() ; - ok my $hdr = $inf->getHeaderInfo(); - ok $inf->close ; - - return $hdr ; -} - -sub printHeaderInfo -{ - my $buffer = shift ; - my $inf = new IO::Uncompress::Inflate \$buffer ; - my $hdr = $inf->getHeaderInfo(); - - no warnings 'uninitialized' ; - while (my ($k, $v) = each %$hdr) { - print " $k -> $v\n" ; - } -} - - -# Check the Deflate Header Parameters -#======================================== - -my $lex = new LexFile my $name ; - -{ - title "Check default header settings" ; - - my $string = <<EOM; -some text -EOM - - my $hdr = ReadHeaderInfo($string); - - is $hdr->{CM}, 8, " CM is 8"; - is $hdr->{FDICT}, 0, " FDICT is 0"; - -} - -{ - title "Check user-defined header settings match zlib" ; - - my $string = <<EOM; -some text -EOM - - my @tests = ( - [ {-Level => 0}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], - [ {-Level => 1}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], - [ {-Level => 2}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], - [ {-Level => 3}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], - [ {-Level => 4}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], - [ {-Level => 5}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], - [ {-Level => 6}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], - [ {-Level => 7}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], - [ {-Level => 8}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], - [ {-Level => 9}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], - - [ {-Level => Z_NO_COMPRESSION }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], - [ {-Level => Z_BEST_SPEED }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], - [ {-Level => Z_BEST_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], - [ {-Level => Z_DEFAULT_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], - - [ {-Strategy => Z_HUFFMAN_ONLY}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], - [ {-Strategy => Z_HUFFMAN_ONLY, - -Level => 3 }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], - ); - - foreach my $test (@tests) - { - my $opts = $test->[0] ; - my $expect = $test->[1] ; - - my @title ; - while (my ($k, $v) = each %$opts) - { - push @title, "$k => $v"; - } - title " Set @title"; - - my $hdr = ReadHeaderInfo($string, %$opts); - - my $hdr1 = ReadHeaderInfoZlib($string, %$opts); - - is $hdr->{CM}, 8, " CM is 8"; - is $hdr->{CINFO}, 7, " CINFO is 7"; - is $hdr->{FDICT}, 0, " FDICT is 0"; - - while (my ($k, $v) = each %$expect) - { - if (ZLIB_VERNUM >= 0x1220) - { is $hdr->{$k}, $v, " $k is $v" } - else - { ok 1, " Skip test for $k" } - } - - is $hdr->{CM}, $hdr1->{CM}, " CM matches"; - is $hdr->{CINFO}, $hdr1->{CINFO}, " CINFO matches"; - is $hdr->{FDICT}, $hdr1->{FDICT}, " FDICT matches"; - is $hdr->{FLEVEL}, $hdr1->{FLEVEL}, " FLEVEL matches"; - is $hdr->{FCHECK}, $hdr1->{FCHECK}, " FCHECK matches"; - } - - -} - -{ - title "No compressed data at all"; - - my $hdr = ReadHeaderInfo(""); - - is $hdr->{CM}, 8, " CM is 8"; - is $hdr->{FDICT}, 0, " FDICT is 0"; - - ok defined $hdr->{ADLER32}, " ADLER32 is defined" ; - is $hdr->{ADLER32}, 1, " ADLER32 is 1"; -} - -{ - # Header Corruption Tests - - my $string = <<EOM; -some text -EOM - - my $good ; - ok my $x = new IO::Compress::Deflate \$good ; - ok $x->write($string) ; - ok $x->close ; - - { - title "Header Corruption - FCHECK failure - 1st byte wrong"; - my $buffer = $good ; - substr($buffer, 0, 1) = "\x00" ; - - ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; - like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', - "CRC mismatch"; - } - - { - title "Header Corruption - FCHECK failure - 2nd byte wrong"; - my $buffer = $good ; - substr($buffer, 1, 1) = "\x00" ; - - ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; - like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', - "CRC mismatch"; - } - - - sub mkZlibHdr - { - my $method = shift ; - my $cinfo = shift ; - my $fdict = shift ; - my $level = shift ; - - my $cmf = ($method & 0x0F) ; - $cmf |= (($cinfo & 0x0F) << 4) ; - my $flg = (($level & 0x03) << 6) ; - $flg |= (($fdict & 0x01) << 5) ; - my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ; - $flg |= $fcheck ; - #print "check $fcheck\n"; - - return pack("CC", $cmf, $flg) ; - } - - { - title "Header Corruption - CM not 8"; - my $buffer = $good ; - my $header = mkZlibHdr(3, 6, 0, 3); - - substr($buffer, 0, 2) = $header; - - my $un = new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; - ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; - like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/', - " Not Deflate"; - } - -} - -{ - # Trailer Corruption tests - - my $string = <<EOM; -some text -EOM - - my $good ; - ok my $x = new IO::Compress::Deflate \$good ; - ok $x->write($string) ; - ok $x->close ; - - foreach my $trim (-4 .. -1) - { - my $got = $trim + 4 ; - foreach my $s (0, 1) - { - title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ; - my $buffer = $good ; - my $expected_trailing = substr($good, -4, 4) ; - substr($expected_trailing, $trim) = ''; - - substr($buffer, $trim) = ''; - writeFile($name, $buffer) ; - - ok my $gunz = new IO::Uncompress::Inflate $name, Strict => $s; - my $uncomp ; - if ($s) - { - ok $gunz->read($uncomp) < 0 ; - like $IO::Uncompress::Inflate::InflateError,"/Trailer Error: trailer truncated. Expected 4 bytes, got $got/", - "Trailer Error"; - } - else - { - is $gunz->read($uncomp), length $string ; - } - ok $gunz->eof() ; - ok $uncomp eq $string; - ok $gunz->close ; - } - - } - - { - title "Trailer Corruption - CRC Wrong, strict" ; - my $buffer = $good ; - my $crc = unpack("N", substr($buffer, -4, 4)); - substr($buffer, -4, 4) = pack('N', $crc+1); - writeFile($name, $buffer) ; - - ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 1; - my $uncomp ; - ok $gunz->read($uncomp) < 0 ; - like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/', - "Trailer Error: CRC mismatch"; - ok $gunz->eof() ; - ok ! $gunz->trailingData() ; - ok $uncomp eq $string; - ok $gunz->close ; - } - - { - title "Trailer Corruption - CRC Wrong, no strict" ; - my $buffer = $good ; - my $crc = unpack("N", substr($buffer, -4, 4)); - substr($buffer, -4, 4) = pack('N', $crc+1); - writeFile($name, $buffer) ; - - ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 0; - my $uncomp ; - ok $gunz->read($uncomp) >= 0 ; - ok $gunz->eof() ; - ok ! $gunz->trailingData() ; - ok $uncomp eq $string; - ok $gunz->close ; - } -} - diff --git a/ext/IO-Compress/t/006zip.t b/ext/IO-Compress/t/006zip.t deleted file mode 100644 index 2dfa52cabb..0000000000 --- a/ext/IO-Compress/t/006zip.t +++ /dev/null @@ -1,275 +0,0 @@ -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 => 77 + $extra ; - - use_ok('IO::Compress::Zip', qw(:all)) ; - use_ok('IO::Uncompress::Unzip', qw(unzip $UnzipError)) ; - - eval { - require IO::Compress::Bzip2 ; - import IO::Compress::Bzip2 2.010 ; - require IO::Uncompress::Bunzip2 ; - import IO::Uncompress::Bunzip2 2.010 ; - } ; - -} - - -sub getContent -{ - my $filename = shift; - - my $u = new IO::Uncompress::Unzip $filename, Append => 1 - or die "Cannot open $filename: $UnzipError"; - - isa_ok $u, "IO::Uncompress::Unzip"; - - my @content; - my $status ; - - for ($status = 1; ! $u->eof(); $status = $u->nextStream()) - { - my $name = $u->getHeaderInfo()->{Name}; - #warn "Processing member $name\n" ; - - my $buff = ''; - 1 while ($status = $u->read($buff)) ; - - push @content, $buff; - last unless $status == 0; - } - - die "Error processing $filename: $status $!\n" - if $status < 0 ; - - return @content; -} - - -{ - title "Create a simple zip - All Deflate"; - - my $lex = new LexFile my $file1; - - my @content = ( - 'hello', - '', - 'goodbye ', - ); - - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0; - isa_ok $zip, "IO::Compress::Zip"; - - is $zip->write($content[0]), length($content[0]), "write"; - $zip->newStream(Name=> "two", Method => ZIP_CM_DEFLATE); - is $zip->write($content[1]), length($content[1]), "write"; - $zip->newStream(Name=> "three", Method => ZIP_CM_DEFLATE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; - - my @got = getContent($file1); - - is $got[0], $content[0], "Got 1st entry"; - is $got[1], $content[1], "Got 2nd entry"; - is $got[2], $content[2], "Got 3nd entry"; -} - -SKIP: -{ - title "Create a simple zip - All Bzip2"; - - skip "IO::Compress::Bzip2 not available", 9 - unless defined $IO::Compress::Bzip2::VERSION; - - my $lex = new LexFile my $file1; - - my @content = ( - 'hello', - '', - 'goodbye ', - ); - - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_BZIP2, Stream => 0; - isa_ok $zip, "IO::Compress::Zip"; - - is $zip->write($content[0]), length($content[0]), "write"; - $zip->newStream(Name=> "two", Method => ZIP_CM_BZIP2); - is $zip->write($content[1]), length($content[1]), "write"; - $zip->newStream(Name=> "three", Method => ZIP_CM_BZIP2); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; - - my @got = getContent($file1); - - is $got[0], $content[0], "Got 1st entry"; - is $got[1], $content[1], "Got 2nd entry"; - is $got[2], $content[2], "Got 3nd entry"; -} - -SKIP: -{ - title "Create a simple zip - Deflate + Bzip2"; - - skip "IO::Compress::Bzip2 not available", 9 - unless $IO::Compress::Bzip2::VERSION; - - my $lex = new LexFile my $file1; - - my @content = ( - 'hello', - 'and', - 'goodbye ', - ); - - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0; - isa_ok $zip, "IO::Compress::Zip"; - - is $zip->write($content[0]), length($content[0]), "write"; - $zip->newStream(Name=> "two", Method => ZIP_CM_BZIP2); - is $zip->write($content[1]), length($content[1]), "write"; - $zip->newStream(Name=> "three", Method => ZIP_CM_DEFLATE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; - - my @got = getContent($file1); - - is $got[0], $content[0], "Got 1st entry"; - is $got[1], $content[1], "Got 2nd entry"; - is $got[2], $content[2], "Got 3nd entry"; -} - -{ - title "Create a simple zip - All STORE"; - - my $lex = new LexFile my $file1; - - my @content = ( - 'hello', - '', - 'goodbye ', - ); - - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_STORE, Stream => 0; - isa_ok $zip, "IO::Compress::Zip"; - - is $zip->write($content[0]), length($content[0]), "write"; - $zip->newStream(Name=> "two", Method => ZIP_CM_STORE); - is $zip->write($content[1]), length($content[1]), "write"; - $zip->newStream(Name=> "three", Method => ZIP_CM_STORE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; - - my @got = getContent($file1); - - is $got[0], $content[0], "Got 1st entry"; - is $got[1], $content[1], "Got 2nd entry"; - is $got[2], $content[2], "Got 3nd entry"; -} - -{ - title "Create a simple zip - Deflate + STORE"; - - my $lex = new LexFile my $file1; - - my @content = qw( - hello - and - goodbye - ); - - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0; - isa_ok $zip, "IO::Compress::Zip"; - - is $zip->write($content[0]), length($content[0]), "write"; - $zip->newStream(Name=> "two", Method => ZIP_CM_STORE); - is $zip->write($content[1]), length($content[1]), "write"; - $zip->newStream(Name=> "three", Method => ZIP_CM_DEFLATE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; - - my @got = getContent($file1); - - is $got[0], $content[0], "Got 1st entry"; - is $got[1], $content[1], "Got 2nd entry"; - is $got[2], $content[2], "Got 3nd entry"; -} - -{ - title "Create a simple zip - Deflate + zero length STORE"; - - my $lex = new LexFile my $file1; - - my @content = ( - 'hello ', - '', - 'goodbye ', - ); - - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0; - isa_ok $zip, "IO::Compress::Zip"; - - is $zip->write($content[0]), length($content[0]), "write"; - $zip->newStream(Name=> "two", Method => ZIP_CM_STORE); - is $zip->write($content[1]), length($content[1]), "write"; - $zip->newStream(Name=> "three", Method => ZIP_CM_DEFLATE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; - - my @got = getContent($file1); - - is $got[0], $content[0], "Got 1st entry"; - ok $got[1] eq $content[1], "Got 2nd entry"; - is $got[2], $content[2], "Got 3nd entry"; -} - - -SKIP: -for my $method (ZIP_CM_DEFLATE, ZIP_CM_STORE, ZIP_CM_BZIP2) -{ - title "Read a line from zip, Method $method"; - - skip "IO::Compress::Bzip2 not available", 14 - unless defined $IO::Compress::Bzip2::VERSION; - - my $content = "a single line\n"; - my $zip ; - - my $status = zip \$content => \$zip, - Method => $method, - Stream => 0, - Name => "123"; - is $status, 1, " Created a zip file"; - - my $u = new IO::Uncompress::Unzip \$zip; - isa_ok $u, "IO::Uncompress::Unzip"; - - is $u->getline, $content, " Read first line ok"; - ok ! $u->getline, " Second line doesn't exist"; - - -} diff --git a/ext/IO-Compress/t/010examples-bzip2.t b/ext/IO-Compress/t/010examples-bzip2.t deleted file mode 100644 index 9bb5eb20e7..0000000000 --- a/ext/IO-Compress/t/010examples-bzip2.t +++ /dev/null @@ -1,145 +0,0 @@ -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; -use IO::Compress::Bzip2 'bzip2' ; - -BEGIN -{ - plan(skip_all => "Examples needs Perl 5.005 or better - you have Perl $]" ) - if $] < 5.005 ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 19 + $extra ; -} - - -my $Inc = join " ", map qq["-I$_"] => @INC; -$Inc = '"-MExtUtils::testlib"' - if ! $ENV{PERL_CORE} && eval " require ExtUtils::testlib; " ; - -my $Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; -$Perl = qq["$Perl"] if $^O eq 'MSWin32' ; - -$Perl = "$Perl $Inc -w" ; -#$Perl .= " -Mblib " ; -my $examples = $ENV{PERL_CORE} ? "../ext/IO-Compress/examples/io/bzip2" - : "./examples/io/bzip2"; - -my $hello1 = <<EOM ; -hello -this is -a test -message -x ttttt -xuuuuuu -the end -EOM - -my @hello1 = grep(s/$/\n/, split(/\n/, $hello1)) ; - -my $hello2 = <<EOM; - -Howdy -this is the -second -file -x ppppp -xuuuuuu -really the end -EOM - -my @hello2 = grep(s/$/\n/, split(/\n/, $hello2)) ; - -my $file1 = "hello1.gz" ; -my $file2 = "hello2.gz" ; -my $stderr = "err.out" ; - -for ($file1, $file2, $stderr) { 1 while unlink $_ } ; - - -bzip2 \$hello1 => $file1 ; -bzip2 \$hello2 => $file2 ; - -sub check -{ - my $command = shift ; - my $expected = shift ; - - my $stderr = 'err.out'; - 1 while unlink $stderr; - - my $cmd = "$command 2>$stderr"; - my $stdout = `$cmd` ; - - my $aok = 1 ; - - $aok &= is $?, 0, " exit status is 0" ; - - $aok &= is readFile($stderr), '', " no stderr" ; - - $aok &= is $stdout, $expected, " expected content is ok" - if defined $expected ; - - if (! $aok) { - diag "Command line: $cmd"; - my ($file, $line) = (caller)[1,2]; - diag "Test called from $file, line $line"; - } - - 1 while unlink $stderr; -} - -# bzcat -# ##### - -title "bzcat - command line" ; -check "$Perl ${examples}/bzcat $file1 $file2", $hello1 . $hello2; - -title "bzcat - stdin" ; -check "$Perl ${examples}/bzcat <$file1 ", $hello1; - - -# bzgrep -# ###### - -title "bzgrep"; -check "$Perl ${examples}/bzgrep the $file1 $file2", - join('', grep(/the/, @hello1, @hello2)); - -for ($file1, $file2, $stderr) { 1 while unlink $_ } ; - - - -# bzstream -# ######## - -{ - title "bzstream" ; - writeFile($file1, $hello1) ; - check "$Perl ${examples}/bzstream <$file1 >$file2"; - - title "bzcat" ; - check "$Perl ${examples}/bzcat $file2", $hello1 ; -} - -END -{ - for ($file1, $file2, $stderr) { 1 while unlink $_ } ; -} - diff --git a/ext/IO-Compress/t/010examples-zlib.t b/ext/IO-Compress/t/010examples-zlib.t deleted file mode 100644 index 712c0b4934..0000000000 --- a/ext/IO-Compress/t/010examples-zlib.t +++ /dev/null @@ -1,145 +0,0 @@ -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; -use IO::Compress::Gzip 'gzip' ; - -BEGIN -{ - plan(skip_all => "Examples needs Perl 5.005 or better - you have Perl $]" ) - if $] < 5.005 ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 19 + $extra ; -} - - -my $Inc = join " ", map qq["-I$_"] => @INC; -$Inc = '"-MExtUtils::testlib"' - if ! $ENV{PERL_CORE} && eval " require ExtUtils::testlib; " ; - -my $Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; -$Perl = qq["$Perl"] if $^O eq 'MSWin32' ; - -$Perl = "$Perl $Inc -w" ; -#$Perl .= " -Mblib " ; -my $examples = $ENV{PERL_CORE} ? "../ext/IO-Compress/examples/io/gzip" - : "./examples/io/gzip"; - -my $hello1 = <<EOM ; -hello -this is -a test -message -x ttttt -xuuuuuu -the end -EOM - -my @hello1 = grep(s/$/\n/, split(/\n/, $hello1)) ; - -my $hello2 = <<EOM; - -Howdy -this is the -second -file -x ppppp -xuuuuuu -really the end -EOM - -my @hello2 = grep(s/$/\n/, split(/\n/, $hello2)) ; - -my $file1 = "hello1.gz" ; -my $file2 = "hello2.gz" ; -my $stderr = "err.out" ; - -for ($file1, $file2, $stderr) { 1 while unlink $_ } ; - - -gzip \$hello1 => $file1 ; -gzip \$hello2 => $file2 ; - -sub check -{ - my $command = shift ; - my $expected = shift ; - - my $stderr = 'err.out'; - 1 while unlink $stderr; - - my $cmd = "$command 2>$stderr"; - my $stdout = `$cmd` ; - - my $aok = 1 ; - - $aok &= is $?, 0, " exit status is 0" ; - - $aok &= is readFile($stderr), '', " no stderr" ; - - $aok &= is $stdout, $expected, " expected content is ok" - if defined $expected ; - - if (! $aok) { - diag "Command line: $cmd"; - my ($file, $line) = (caller)[1,2]; - diag "Test called from $file, line $line"; - } - - 1 while unlink $stderr; -} - -# gzcat -# ##### - -title "gzcat - command line" ; -check "$Perl ${examples}/gzcat $file1 $file2", $hello1 . $hello2; - -title "gzcat - stdin" ; -check "$Perl ${examples}/gzcat <$file1 ", $hello1; - - -# gzgrep -# ###### - -title "gzgrep"; -check "$Perl ${examples}/gzgrep the $file1 $file2", - join('', grep(/the/, @hello1, @hello2)); - -for ($file1, $file2, $stderr) { 1 while unlink $_ } ; - - - -# gzstream -# ######## - -{ - title "gzstream" ; - writeFile($file1, $hello1) ; - check "$Perl ${examples}/gzstream <$file1 >$file2"; - - title "gzcat" ; - check "$Perl ${examples}/gzcat $file2", $hello1 ; -} - -END -{ - for ($file1, $file2, $stderr) { 1 while unlink $_ } ; -} - diff --git a/ext/IO-Compress/t/01misc.t b/ext/IO-Compress/t/01misc.t deleted file mode 100644 index a7a31fbe15..0000000000 --- a/ext/IO-Compress/t/01misc.t +++ /dev/null @@ -1,314 +0,0 @@ -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 => 118 + $extra ; - - use_ok('Scalar::Util'); - use_ok('IO::Compress::Base::Common'); -} - - -ok gotScalarUtilXS(), "Got XS Version of Scalar::Util" - or diag <<EOM; -You don't have the XS version of Scalar::Util -EOM - -# 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'"; - - - SKIP: - { - use Config; - - skip 'readonly + threads', 1 - if $Config{useithreads}; - - eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => 'abc') ; }; - like $@, mkErr("Parameter 'Fred' not writable"), - "wanted writable, got readonly"; - } - - my @xx; - eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => \@xx) ; }; - like $@, mkErr("Parameter 'Fred' not a scalar reference"), - "wanted scalar reference"; - - local *ABC; - eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => *ABC) ; }; - like $@, mkErr("Parameter 'Fred' not a scalar"), - "wanted scalar"; - - #eval { ParseParameters(1, {'Fred' => [1, 1, Parse_any|Parse_multiple, 0]}, Fred => 1, Fred => 2) ; }; - #like $@, mkErr("Muliple instances of 'Fred' found"), - #"wanted scalar"; - - ok 1; - - my $got = ParseParameters(1, {'Fred' => [1, 1, 0x1000000, 0]}, Fred => 'abc') ; - is $got->value('Fred'), "abc", "other" ; - - $got = ParseParameters(1, {'Fred' => [0, 1, Parse_any, undef]}, Fred => undef) ; - ok $got->parsed('Fred'), "undef" ; - ok ! defined $got->value('Fred'), "undef" ; - - $got = ParseParameters(1, {'Fred' => [0, 1, Parse_string, undef]}, Fred => undef) ; - ok $got->parsed('Fred'), "undef" ; - is $got->value('Fred'), "", "empty string" ; - - my $xx; - $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => $xx) ; - - ok $got->parsed('Fred'), "parsed" ; - my $xx_ref = $got->value('Fred'); - $$xx_ref = 77 ; - is $xx, 77; - - $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => \$xx) ; - - ok $got->parsed('Fred'), "parsed" ; - $xx_ref = $got->value('Fred'); - - $$xx_ref = 666 ; - is $xx, 666; - - { - my $got1 = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, $got) ; - is $got1, $got, "Same object"; - - ok $got1->parsed('Fred'), "parsed" ; - $xx_ref = $got1->value('Fred'); - - $$xx_ref = 777 ; - is $xx, 777; - } - - my $got2 = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, '__xxx__' => $got) ; - isnt $got2, $got, "not the Same object"; - - ok $got2->parsed('Fred'), "parsed" ; - $xx_ref = $got2->value('Fred'); - $$xx_ref = 888 ; - is $xx, 888; - - my $other; - my $got3 = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, '__xxx__' => $got, Fred => \$other) ; - isnt $got3, $got, "not the Same object"; - - ok $got3->parsed('Fred'), "parsed" ; - $xx_ref = $got3->value('Fred'); - $$xx_ref = 999 ; - is $other, 999; - is $xx, 888; -} - - -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"; - -} - -# U64 - -{ - title "U64" ; - - my $x = new U64(); - is $x->getHigh, 0, " getHigh is 0"; - is $x->getLow, 0, " getLow is 0"; - ok ! $x->is64bit(), " ! is64bit"; - - $x = new U64(1,2); - is $x->getHigh, 1, " getHigh is 1"; - is $x->getLow, 2, " getLow is 2"; - ok $x->is64bit(), " is64bit"; - - $x = new U64(0xFFFFFFFF,2); - is $x->getHigh, 0xFFFFFFFF, " getHigh is 0xFFFFFFFF"; - is $x->getLow, 2, " getLow is 2"; - ok $x->is64bit(), " is64bit"; - - $x = new U64(7, 0xFFFFFFFF); - is $x->getHigh, 7, " getHigh is 7"; - is $x->getLow, 0xFFFFFFFF, " getLow is 0xFFFFFFFF"; - ok $x->is64bit(), " is64bit"; - - $x = new U64(666); - is $x->getHigh, 0, " getHigh is 0"; - is $x->getLow, 666, " getLow is 666"; - ok ! $x->is64bit(), " ! is64bit"; - - title "U64 - add" ; - - $x = new U64(0, 1); - is $x->getHigh, 0, " getHigh is 0"; - is $x->getLow, 1, " getLow is 1"; - ok ! $x->is64bit(), " ! is64bit"; - - $x->add(1); - is $x->getHigh, 0, " getHigh is 0"; - is $x->getLow, 2, " getLow is 2"; - ok ! $x->is64bit(), " ! is64bit"; - - $x = new U64(0, 0xFFFFFFFE); - is $x->getHigh, 0, " getHigh is 0"; - is $x->getLow, 0xFFFFFFFE, " getLow is 0xFFFFFFFE"; - is $x->get32bit(), 0xFFFFFFFE, " get32bit is 0xFFFFFFFE"; - is $x->get64bit(), 0xFFFFFFFE, " get64bit is 0xFFFFFFFE"; - ok ! $x->is64bit(), " ! is64bit"; - - $x->add(1); - is $x->getHigh, 0, " getHigh is 0"; - is $x->getLow, 0xFFFFFFFF, " getLow is 0xFFFFFFFF"; - is $x->get32bit(), 0xFFFFFFFF, " get32bit is 0xFFFFFFFF"; - is $x->get64bit(), 0xFFFFFFFF, " get64bit is 0xFFFFFFFF"; - ok ! $x->is64bit(), " ! is64bit"; - - $x->add(1); - is $x->getHigh, 1, " getHigh is 1"; - is $x->getLow, 0, " getLow is 0"; - is $x->get32bit(), 0x0, " get32bit is 0x0"; - is $x->get64bit(), 0xFFFFFFFF+1, " get64bit is 0x100000000"; - ok $x->is64bit(), " is64bit"; - - $x->add(1); - is $x->getHigh, 1, " getHigh is 1"; - is $x->getLow, 1, " getLow is 1"; - is $x->get32bit(), 0x1, " get32bit is 0x1"; - is $x->get64bit(), 0xFFFFFFFF+2, " get64bit is 0x100000001"; - ok $x->is64bit(), " is64bit"; - - $x->add(1); - is $x->getHigh, 1, " getHigh is 1"; - is $x->getLow, 2, " getLow is 1"; - is $x->get32bit(), 0x2, " get32bit is 0x2"; - is $x->get64bit(), 0xFFFFFFFF+3, " get64bit is 0x100000002"; - ok $x->is64bit(), " is64bit"; - - $x = new U64(1, 0xFFFFFFFE); - my $y = new U64(2, 3); - - $x->add($y); - is $x->getHigh, 4, " getHigh is 4"; - is $x->getLow, 1, " getLow is 1"; - ok $x->is64bit(), " is64bit"; - - title "U64 - equal" ; - - $x = new U64(0, 1); - is $x->getHigh, 0, " getHigh is 0"; - is $x->getLow, 1, " getLow is 1"; - ok ! $x->is64bit(), " ! is64bit"; - - $y = new U64(0, 1); - is $y->getHigh, 0, " getHigh is 0"; - is $y->getLow, 1, " getLow is 1"; - ok ! $y->is64bit(), " ! is64bit"; - - my $z = new U64(0, 2); - is $z->getHigh, 0, " getHigh is 0"; - is $z->getLow, 2, " getLow is 2"; - ok ! $z->is64bit(), " ! is64bit"; - - ok $x->equal($y), " equal"; - ok !$x->equal($z), " ! equal"; - - title "U64 - clone" ; - $x = new U64(21, 77); - $z = U64::clone($x); - is $z->getHigh, 21, " getHigh is 21"; - is $z->getLow, 77, " getLow is 77"; -} diff --git a/ext/IO-Compress/t/020isize.t b/ext/IO-Compress/t/020isize.t deleted file mode 100644 index c600c95f34..0000000000 --- a/ext/IO-Compress/t/020isize.t +++ /dev/null @@ -1,158 +0,0 @@ -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 -{ - plan skip_all => "Lengthy Tests Disabled\n" . - "set COMPRESS_ZLIB_RUN_ALL to run this test suite" - unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 76 + $extra ; - - - use_ok('Compress::Zlib', 2) ; - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - use_ok('IO::Compress::Gzip::Constants'); -} - -my $compressed ; -my $expected_crc ; - -for my $wrap (0 .. 2) -{ - for my $offset ( -1 .. 1 ) - { - next if $wrap == 0 && $offset < 0 ; - - title "Wrap $wrap, Offset $offset" ; - - my $size = (GZIP_ISIZE_MAX * $wrap) + $offset ; - - my $expected_isize ; - if ($wrap == 0) { - $expected_isize = $offset ; - } - elsif ($wrap == 1 && $offset <= 0) { - $expected_isize = GZIP_ISIZE_MAX + $offset ; - } - elsif ($wrap > 1) { - $expected_isize = GZIP_ISIZE_MAX + $offset - 1; - } - else { - $expected_isize = $offset - 1; - } - - sub gzipClosure - { - my $gzip = shift ; - my $max = shift ; - - my $index = 0 ; - my $inc = 1024 * 5000 ; - my $buff = 'x' x $inc ; - my $left = $max ; - - return - sub { - - if ($max == 0 && $index == 0) { - $expected_crc = crc32('') ; - ok $gzip->close(), ' IO::Compress::Gzip::close ok X' ; - ++ $index ; - $_[0] .= $compressed; - return length $compressed ; - } - - return 0 if $index >= $max ; - - while ( ! length $compressed ) - { - $index += $inc ; - - if ($index <= $max) { - $gzip->write($buff) ; - #print "Write " . length($buff) . "\n" ; - #print "# LEN Compressed " . length($compressed) . "\n" ; - $expected_crc = crc32($buff, $expected_crc) ; - $left -= $inc ; - } - else { - #print "Write $left\n" ; - $gzip->write('x' x $left) ; - #print "# LEN Compressed " . length($compressed) . "\n" ; - $expected_crc = crc32('x' x $left, $expected_crc) ; - ok $gzip->close(), ' IO::Compress::Gzip::close ok ' ; - last ; - } - } - - my $len = length $compressed ; - $_[0] .= $compressed ; - $compressed = ''; - #print "# LEN $len\n" if $len <=0 ; - - return $len ; - }; - } - - my $gzip = new IO::Compress::Gzip \$compressed, - -Append => 0, - -HeaderCRC => 1; - - ok $gzip, " Created IO::Compress::Gzip object"; - - my $gunzip = new IO::Uncompress::Gunzip gzipClosure($gzip, $size), - -BlockSize => 1024 * 500 , - -Append => 0, - -Strict => 1; - - ok $gunzip, " Created IO::Uncompress::Gunzip object"; - - my $inflate = *$gunzip->{Inflate} ; - my $deflate = *$gzip->{Deflate} ; - - my $status ; - my $uncompressed; - my $actual = 0 ; - while (($status = $gunzip->read($uncompressed)) > 0) { - #print "# READ $status\n" ; - $actual += $status ; - } - - is $status, 0, ' IO::Uncompress::Gunzip::read returned 0' - or diag "error status is $status, error is $GunzipError" ; - - ok $gunzip->close(), " IO::Uncompress::Gunzip Closed ok" ; - - is $actual, $size, " Length of Gunzipped data is $size" - or diag "Expected $size, got $actual"; - - my $gunzip_hdr = $gunzip->getHeaderInfo(); - - is $gunzip_hdr->{ISIZE}, $expected_isize, - sprintf(" ISIZE is $expected_isize [0x%X]", $expected_isize); - is $gunzip_hdr->{CRC32}, $expected_crc, - sprintf(" CRC32 is $expected_crc [0x%X]", $expected_crc); - - $expected_crc = 0 ; - } -} - diff --git a/ext/IO-Compress/t/050interop-gzip.t b/ext/IO-Compress/t/050interop-gzip.t deleted file mode 100644 index 22be0646c8..0000000000 --- a/ext/IO-Compress/t/050interop-gzip.t +++ /dev/null @@ -1,143 +0,0 @@ -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; - -my $GZIP ; - - -sub ExternalGzipWorks -{ - my $lex = new LexFile my $outfile; - my $content = qq { -Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Ut tempus odio id - dolor. Camelus perlus. Larrius in lumen numen. Dolor en quiquum filia - est. Quintus cenum parat. -}; - - writeWithGzip($outfile, $content) - or return 0; - - my $got ; - readWithGzip($outfile, $got) - or return 0; - - if ($content ne $got) - { - diag "Uncompressed content is wrong"; - return 0 ; - } - - return 1 ; -} - -sub readWithGzip -{ - my $file = shift ; - - my $lex = new LexFile my $outfile; - - my $comp = "$GZIP -dc" ; - - if ( system("$comp $file >$outfile") == 0 ) - { - $_[0] = readFile($outfile); - return 1 - } - - diag "'$comp' failed: $?"; - return 0 ; -} - -sub getGzipInfo -{ - my $file = shift ; -} - -sub writeWithGzip -{ - my $file = shift ; - my $content = shift ; - my $options = shift || ''; - - my $lex = new LexFile my $infile; - writeFile($infile, $content); - - unlink $file ; - my $comp = "$GZIP -c $options $infile >$file" ; - - return 1 - if system($comp) == 0 ; - - diag "'$comp' failed: $?"; - return 0 ; -} - -BEGIN { - - # Check external gzip is available - my $name = $^O =~ /mswin/i ? 'gzip.exe' : 'gzip'; - my $split = $^O =~ /mswin/i ? ";" : ":"; - - for my $dir (reverse split $split, $ENV{PATH}) - { - $GZIP = "$dir/$name" - if -x "$dir/$name" ; - } - - plan(skip_all => "Cannot find $name") - if ! $GZIP ; - - plan(skip_all => "$name doesn't work as expected") - if ! ExternalGzipWorks(); - - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 7 + $extra ; - - use_ok('IO::Compress::Gzip', ':all') ; - use_ok('IO::Uncompress::Gunzip', ':all') ; - -} - - -{ - title "Test interop with $GZIP" ; - - my $file; - my $file1; - my $lex = new LexFile $file, $file1; - my $content = qq { -Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Ut tempus odio id - dolor. Camelus perlus. Larrius in lumen numen. Dolor en quiquum filia - est. Quintus cenum parat. -}; - my $got; - - ok writeWithGzip($file, $content), "writeWithGzip ok"; - - gunzip $file => \$got ; - is $got, $content, "got content"; - - - gzip \$content => $file1; - $got = ''; - ok readWithGzip($file1, $got), "readWithGzip ok"; - is $got, $content, "got content"; -} - - diff --git a/ext/IO-Compress/t/100generic-bzip2.t b/ext/IO-Compress/t/100generic-bzip2.t deleted file mode 100644 index a9f430e236..0000000000 --- a/ext/IO-Compress/t/100generic-bzip2.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "generic.pl" ; -run(); diff --git a/ext/IO-Compress/t/100generic-deflate.t b/ext/IO-Compress/t/100generic-deflate.t deleted file mode 100644 index 999c9561e2..0000000000 --- a/ext/IO-Compress/t/100generic-deflate.t +++ /dev/null @@ -1,22 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "generic.pl" ; -run(); diff --git a/ext/IO-Compress/t/100generic-gzip.t b/ext/IO-Compress/t/100generic-gzip.t deleted file mode 100644 index 614945ca80..0000000000 --- a/ext/IO-Compress/t/100generic-gzip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - return 'IO::Compress::Gzip'; -} - -require "generic.pl" ; -run(); diff --git a/ext/IO-Compress/t/100generic-rawdeflate.t b/ext/IO-Compress/t/100generic-rawdeflate.t deleted file mode 100644 index b5a43697bd..0000000000 --- a/ext/IO-Compress/t/100generic-rawdeflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "generic.pl" ; -run(); diff --git a/ext/IO-Compress/t/100generic-zip.t b/ext/IO-Compress/t/100generic-zip.t deleted file mode 100644 index 907dada4c5..0000000000 --- a/ext/IO-Compress/t/100generic-zip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "generic.pl" ; -run(); diff --git a/ext/IO-Compress/t/101truncate-bzip2.t b/ext/IO-Compress/t/101truncate-bzip2.t deleted file mode 100644 index 7aba01dd39..0000000000 --- a/ext/IO-Compress/t/101truncate-bzip2.t +++ /dev/null @@ -1,37 +0,0 @@ -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 ; - -BEGIN { - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 912 + $extra; - -}; - - -#use Test::More skip_all => "not implemented yet"; - - -use IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "truncate.pl" ; -run(); diff --git a/ext/IO-Compress/t/101truncate-deflate.t b/ext/IO-Compress/t/101truncate-deflate.t deleted file mode 100644 index 2ae2b312df..0000000000 --- a/ext/IO-Compress/t/101truncate-deflate.t +++ /dev/null @@ -1,37 +0,0 @@ -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 ; - -BEGIN { - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 734 + $extra; - -}; - - -#use Test::More skip_all => "not implemented yet"; - - -use IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "truncate.pl" ; -run(); diff --git a/ext/IO-Compress/t/101truncate-gzip.t b/ext/IO-Compress/t/101truncate-gzip.t deleted file mode 100644 index 1e546b47e9..0000000000 --- a/ext/IO-Compress/t/101truncate-gzip.t +++ /dev/null @@ -1,36 +0,0 @@ -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 skip_all => "not implemented yet"; -use Test::More ; - -BEGIN { - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 978 + $extra; - -}; - - - -use IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - return 'IO::Compress::Gzip'; -} - -require "truncate.pl" ; -run(); diff --git a/ext/IO-Compress/t/101truncate-rawdeflate.t b/ext/IO-Compress/t/101truncate-rawdeflate.t deleted file mode 100644 index d81b54a7b3..0000000000 --- a/ext/IO-Compress/t/101truncate-rawdeflate.t +++ /dev/null @@ -1,130 +0,0 @@ -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 ; - -BEGIN { - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 625 + $extra; - -}; - - -use IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -#sub identify -#{ -# 'IO::Compress::RawDeflate'; -#} -# -#require "truncate.pl" ; -#run(); - -use CompTestUtils; - -my $hello = <<EOM ; -hello world -this is a test -some more stuff on this line -ad finally... -EOM - -my $blocksize = 10 ; - - -foreach my $CompressClass ( 'IO::Compress::RawDeflate') -{ - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($UncompressClass); - - my $compressed ; - ok( my $x = new IO::Compress::RawDeflate \$compressed); - ok $x->write($hello) ; - ok $x->close ; - - - my $cc = $compressed ; - - my $gz ; - ok($gz = new $UncompressClass(\$cc, - -Transparent => 0)) - or diag "$$Error\n"; - my $un; - is $gz->read($un, length($hello)), length($hello); - ok $gz->close(); - is $un, $hello ; - - for my $trans (0 .. 1) - { - title "Testing $CompressClass, Transparent = $trans"; - - my $info = $gz->getHeaderInfo() ; - my $header_size = $info->{HeaderLength}; - my $trailer_size = $info->{TrailerLength}; - ok 1, "Compressed size is " . length($compressed) ; - ok 1, "Header size is $header_size" ; - ok 1, "Trailer size is $trailer_size" ; - - - title "Compressed Data Truncation"; - foreach my $i (0 .. $blocksize) - { - - my $lex = new LexFile my $name ; - - ok 1, "Length $i" ; - my $part = substr($compressed, 0, $i); - writeFile($name, $part); - my $gz = new $UncompressClass $name, - -BlockSize => $blocksize, - -Transparent => $trans; - if ($trans) { - ok $gz; - ok ! $gz->error() ; - my $buff = ''; - is $gz->read($buff, length $part), length $part ; - is $buff, $part ; - ok $gz->eof() ; - $gz->close(); - } - else { - ok !$gz; - } - } - - foreach my $i ($blocksize+1 .. length($compressed)-1) - { - - my $lex = new LexFile my $name ; - - ok 1, "Length $i" ; - my $part = substr($compressed, 0, $i); - writeFile($name, $part); - ok my $gz = new $UncompressClass $name, - -BlockSize => $blocksize, - -Transparent => $trans; - my $un ; - my $status = 1 ; - $status = $gz->read($un) while $status > 0 ; - ok $status < 0 ; - ok $gz->eof() ; - ok $gz->error() ; - $gz->close(); - } - } - -} - diff --git a/ext/IO-Compress/t/101truncate-zip.t b/ext/IO-Compress/t/101truncate-zip.t deleted file mode 100644 index 0bc2c100d0..0000000000 --- a/ext/IO-Compress/t/101truncate-zip.t +++ /dev/null @@ -1,38 +0,0 @@ -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 skip_all => "not implemented yet"; -use Test::More ; - -BEGIN { - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 2404 + $extra; - -}; - - - - - -use IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "truncate.pl" ; -run(); diff --git a/ext/IO-Compress/t/102tied-bzip2.t b/ext/IO-Compress/t/102tied-bzip2.t deleted file mode 100644 index 8503e02529..0000000000 --- a/ext/IO-Compress/t/102tied-bzip2.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "tied.pl" ; -run(); diff --git a/ext/IO-Compress/t/102tied-deflate.t b/ext/IO-Compress/t/102tied-deflate.t deleted file mode 100644 index 8747aee90f..0000000000 --- a/ext/IO-Compress/t/102tied-deflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "tied.pl" ; -run(); diff --git a/ext/IO-Compress/t/102tied-gzip.t b/ext/IO-Compress/t/102tied-gzip.t deleted file mode 100644 index 52a502ecd3..0000000000 --- a/ext/IO-Compress/t/102tied-gzip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "tied.pl" ; -run(); diff --git a/ext/IO-Compress/t/102tied-rawdeflate.t b/ext/IO-Compress/t/102tied-rawdeflate.t deleted file mode 100644 index f3ba80cfc8..0000000000 --- a/ext/IO-Compress/t/102tied-rawdeflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "tied.pl" ; -run(); diff --git a/ext/IO-Compress/t/102tied-zip.t b/ext/IO-Compress/t/102tied-zip.t deleted file mode 100644 index 04be98dc6f..0000000000 --- a/ext/IO-Compress/t/102tied-zip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "tied.pl" ; -run(); diff --git a/ext/IO-Compress/t/103newtied-bzip2.t b/ext/IO-Compress/t/103newtied-bzip2.t deleted file mode 100644 index ecf8a49893..0000000000 --- a/ext/IO-Compress/t/103newtied-bzip2.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "newtied.pl" ; -run(); diff --git a/ext/IO-Compress/t/103newtied-deflate.t b/ext/IO-Compress/t/103newtied-deflate.t deleted file mode 100644 index 42a3d3c2bd..0000000000 --- a/ext/IO-Compress/t/103newtied-deflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "newtied.pl" ; -run(); diff --git a/ext/IO-Compress/t/103newtied-gzip.t b/ext/IO-Compress/t/103newtied-gzip.t deleted file mode 100644 index 7a453fa479..0000000000 --- a/ext/IO-Compress/t/103newtied-gzip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "newtied.pl" ; -run(); diff --git a/ext/IO-Compress/t/103newtied-rawdeflate.t b/ext/IO-Compress/t/103newtied-rawdeflate.t deleted file mode 100644 index 93a5118526..0000000000 --- a/ext/IO-Compress/t/103newtied-rawdeflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "newtied.pl" ; -run(); diff --git a/ext/IO-Compress/t/103newtied-zip.t b/ext/IO-Compress/t/103newtied-zip.t deleted file mode 100644 index 84b19453b7..0000000000 --- a/ext/IO-Compress/t/103newtied-zip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "newtied.pl" ; -run(); diff --git a/ext/IO-Compress/t/104destroy-bzip2.t b/ext/IO-Compress/t/104destroy-bzip2.t deleted file mode 100644 index e8c02cf3d2..0000000000 --- a/ext/IO-Compress/t/104destroy-bzip2.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "destroy.pl" ; -run(); diff --git a/ext/IO-Compress/t/104destroy-deflate.t b/ext/IO-Compress/t/104destroy-deflate.t deleted file mode 100644 index 37511f7df4..0000000000 --- a/ext/IO-Compress/t/104destroy-deflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "destroy.pl" ; -run(); diff --git a/ext/IO-Compress/t/104destroy-gzip.t b/ext/IO-Compress/t/104destroy-gzip.t deleted file mode 100644 index 5f686f480c..0000000000 --- a/ext/IO-Compress/t/104destroy-gzip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "destroy.pl" ; -run(); diff --git a/ext/IO-Compress/t/104destroy-rawdeflate.t b/ext/IO-Compress/t/104destroy-rawdeflate.t deleted file mode 100644 index 1463000e23..0000000000 --- a/ext/IO-Compress/t/104destroy-rawdeflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "destroy.pl" ; -run(); diff --git a/ext/IO-Compress/t/104destroy-zip.t b/ext/IO-Compress/t/104destroy-zip.t deleted file mode 100644 index d071a06d37..0000000000 --- a/ext/IO-Compress/t/104destroy-zip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "destroy.pl" ; -run(); diff --git a/ext/IO-Compress/t/105oneshot-bzip2.t b/ext/IO-Compress/t/105oneshot-bzip2.t deleted file mode 100644 index c402829fe4..0000000000 --- a/ext/IO-Compress/t/105oneshot-bzip2.t +++ /dev/null @@ -1,22 +0,0 @@ -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 IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "oneshot.pl" ; - -run(); diff --git a/ext/IO-Compress/t/105oneshot-deflate.t b/ext/IO-Compress/t/105oneshot-deflate.t deleted file mode 100644 index ab108eaa78..0000000000 --- a/ext/IO-Compress/t/105oneshot-deflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "oneshot.pl" ; -run(); diff --git a/ext/IO-Compress/t/105oneshot-gzip-only.t b/ext/IO-Compress/t/105oneshot-gzip-only.t deleted file mode 100644 index 0382df8e33..0000000000 --- a/ext/IO-Compress/t/105oneshot-gzip-only.t +++ /dev/null @@ -1,134 +0,0 @@ -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 { - plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" ) - if $] < 5.005 ; - - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 70 + $extra ; - - use_ok('IO::Compress::Gzip', qw($GzipError)) ; - use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; - - -} - - -sub gzipGetHeader -{ - my $in = shift; - my $content = shift ; - my %opts = @_ ; - - my $out ; - my $got ; - - ok IO::Compress::Gzip::gzip($in, \$out, %opts), " gzip ok" ; - ok IO::Uncompress::Gunzip::gunzip(\$out, \$got), " gunzip ok" - or diag $GunzipError ; - is $got, $content, " got expected content" ; - - my $gunz = new IO::Uncompress::Gunzip \$out, Strict => 0 - or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; - ok $gunz, " Created IO::Uncompress::Gunzip object"; - my $hdr = $gunz->getHeaderInfo(); - ok $hdr, " got Header info"; - my $uncomp ; - ok $gunz->read($uncomp), " read ok" ; - is $uncomp, $content, " got expected content"; - ok $gunz->close, " closed ok" ; - - return $hdr ; - -} - -{ - title "Check gzip header default NAME & MTIME settings" ; - - my $lex = new LexFile my $file1; - - my $content = "hello "; - my $hdr ; - my $mtime ; - - writeFile($file1, $content); - $mtime = (stat($file1))[9]; - # make sure that the gzip file isn't created in the same - # second as the input file - sleep 3 ; - $hdr = gzipGetHeader($file1, $content); - - is $hdr->{Name}, $file1, " Name is '$file1'"; - is $hdr->{Time}, $mtime, " Time is ok"; - - title "Override Name" ; - - writeFile($file1, $content); - $mtime = (stat($file1))[9]; - sleep 3 ; - $hdr = gzipGetHeader($file1, $content, Name => "abcde"); - - is $hdr->{Name}, "abcde", " Name is 'abcde'" ; - is $hdr->{Time}, $mtime, " Time is ok"; - - title "Override Time" ; - - writeFile($file1, $content); - $hdr = gzipGetHeader($file1, $content, Time => 1234); - - is $hdr->{Name}, $file1, " Name is '$file1'" ; - is $hdr->{Time}, 1234, " Time is 1234"; - - title "Override Name and Time" ; - - writeFile($file1, $content); - $hdr = gzipGetHeader($file1, $content, Time => 4321, Name => "abcde"); - - is $hdr->{Name}, "abcde", " Name is 'abcde'" ; - is $hdr->{Time}, 4321, " Time is 4321"; - - title "Filehandle doesn't have default Name or Time" ; - my $fh = new IO::File "< $file1" - or diag "Cannot open '$file1': $!\n" ; - sleep 3 ; - my $before = time ; - $hdr = gzipGetHeader($fh, $content); - my $after = time ; - - ok ! defined $hdr->{Name}, " Name is undef"; - cmp_ok $hdr->{Time}, '>=', $before, " Time is ok"; - cmp_ok $hdr->{Time}, '<=', $after, " Time is ok"; - - $fh->close; - - title "Buffer doesn't have default Name or Time" ; - my $buffer = $content; - $before = time ; - $hdr = gzipGetHeader(\$buffer, $content); - $after = time ; - - ok ! defined $hdr->{Name}, " Name is undef"; - cmp_ok $hdr->{Time}, '>=', $before, " Time is ok"; - cmp_ok $hdr->{Time}, '<=', $after, " Time is ok"; -} - -# TODO add more error cases - diff --git a/ext/IO-Compress/t/105oneshot-gzip.t b/ext/IO-Compress/t/105oneshot-gzip.t deleted file mode 100644 index 9a45222dc1..0000000000 --- a/ext/IO-Compress/t/105oneshot-gzip.t +++ /dev/null @@ -1,22 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "oneshot.pl" ; - -run(); diff --git a/ext/IO-Compress/t/105oneshot-rawdeflate.t b/ext/IO-Compress/t/105oneshot-rawdeflate.t deleted file mode 100644 index 50cb80a3c1..0000000000 --- a/ext/IO-Compress/t/105oneshot-rawdeflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "oneshot.pl" ; -run(); diff --git a/ext/IO-Compress/t/105oneshot-zip-bzip2-only.t b/ext/IO-Compress/t/105oneshot-zip-bzip2-only.t deleted file mode 100644 index f21e918b87..0000000000 --- a/ext/IO-Compress/t/105oneshot-zip-bzip2-only.t +++ /dev/null @@ -1,168 +0,0 @@ -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 { - plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" ) - if $] < 5.005 ; - - plan(skip_all => "IO::Compress::Bzip2 not available" ) - unless eval { require IO::Compress::Bzip2; - require IO::Uncompress::Bunzip2; - 1 - } ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 144 + $extra ; - - #use_ok('IO::Compress::Zip', qw(zip $ZipError :zip_method)) ; - use_ok('IO::Compress::Zip', qw(:all)) ; - use_ok('IO::Uncompress::Unzip', qw(unzip $UnzipError)) ; - - -} - - -sub zipGetHeader -{ - my $in = shift; - my $content = shift ; - my %opts = @_ ; - - my $out ; - my $got ; - - ok zip($in, \$out, %opts), " zip ok" ; - ok unzip(\$out, \$got), " unzip ok" - or diag $UnzipError ; - is $got, $content, " got expected content" ; - - my $gunz = new IO::Uncompress::Unzip \$out, Strict => 0 - or diag "UnzipError is $IO::Uncompress::Unzip::UnzipError" ; - ok $gunz, " Created IO::Uncompress::Unzip object"; - my $hdr = $gunz->getHeaderInfo(); - ok $hdr, " got Header info"; - my $uncomp ; - ok $gunz->read($uncomp), " read ok" ; - is $uncomp, $content, " got expected content"; - ok $gunz->close, " closed ok" ; - - return $hdr ; - -} - - -for my $stream (0, 1) -{ - for my $zip64 (0, 1) - { - #next if $zip64 && ! $stream; - - for my $method (ZIP_CM_STORE, ZIP_CM_DEFLATE, ZIP_CM_BZIP2) - { - title "Stream $stream, Zip64 $zip64, Method $method"; - - my $lex = new LexFile my $file1; - - my $content = "hello "; - #writeFile($file1, $content); - - ok zip(\$content => $file1 , Method => $method, - Zip64 => $zip64, - Stream => $stream), " zip ok" - or diag $ZipError ; - - my $got ; - if ($stream && $method == ZIP_CM_STORE ) { - #eval ' unzip($file1 => \$got) '; - ok ! unzip($file1 => \$got), " unzip fails"; - like $UnzipError, "/Streamed Stored content not supported/", - " Streamed Stored content not supported"; - next ; - } - - ok unzip($file1 => \$got), " unzip ok" - or diag $UnzipError ; - - is $got, $content, " content ok"; - - my $u = new IO::Uncompress::Unzip $file1 - or diag $ZipError ; - - my $hdr = $u->getHeaderInfo(); - ok $hdr, " got header"; - - is $hdr->{Stream}, $stream, " stream is $stream" ; - is $hdr->{MethodID}, $method, " MethodID is $method" ; - is $hdr->{Zip64}, $zip64, " Zip64 is $zip64" ; - } - } -} - -for my $stream (0, 1) -{ - for my $zip64 (0, 1) - { - next if $zip64 && ! $stream; - - for my $method (ZIP_CM_STORE, ZIP_CM_DEFLATE, ZIP_CM_BZIP2) - { - title "Stream $stream, Zip64 $zip64, Method $method"; - - my $file1; - my $file2; - my $zipfile; - my $lex = new LexFile $file1, $file2, $zipfile; - - my $content1 = "hello "; - writeFile($file1, $content1); - - my $content2 = "goodbye "; - writeFile($file2, $content2); - - my %content = ( $file1 => $content1, - $file2 => $content2, - ); - - ok zip([$file1, $file2] => $zipfile , Method => $method, - Zip64 => $zip64, - Stream => $stream), " zip ok" - or diag $ZipError ; - - for my $file ($file1, $file2) - { - my $got ; - if ($stream && $method == ZIP_CM_STORE ) { - #eval ' unzip($zipfile => \$got) '; - ok ! unzip($zipfile => \$got, Name => $file), " unzip fails"; - like $UnzipError, "/Streamed Stored content not supported/", - " Streamed Stored content not supported"; - next ; - } - - ok unzip($zipfile => \$got, Name => $file), " unzip $file ok" - or diag $UnzipError ; - - is $got, $content{$file}, " content ok"; - } - } - } -} - -# TODO add more error cases - diff --git a/ext/IO-Compress/t/105oneshot-zip-only.t b/ext/IO-Compress/t/105oneshot-zip-only.t deleted file mode 100644 index 0906bf6e16..0000000000 --- a/ext/IO-Compress/t/105oneshot-zip-only.t +++ /dev/null @@ -1,237 +0,0 @@ -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 { - plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" ) - if $] < 5.005 ; - - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 162 + $extra ; - - #use_ok('IO::Compress::Zip', qw(zip $ZipError :zip_method)) ; - use_ok('IO::Compress::Zip', qw(:all)) ; - use_ok('IO::Uncompress::Unzip', qw(unzip $UnzipError)) ; - - -} - - -sub zipGetHeader -{ - my $in = shift; - my $content = shift ; - my %opts = @_ ; - - my $out ; - my $got ; - - ok zip($in, \$out, %opts), " zip ok" ; - ok unzip(\$out, \$got), " unzip ok" - or diag $UnzipError ; - is $got, $content, " got expected content" ; - - my $gunz = new IO::Uncompress::Unzip \$out, Strict => 0 - or diag "UnzipError is $IO::Uncompress::Unzip::UnzipError" ; - ok $gunz, " Created IO::Uncompress::Unzip object"; - my $hdr = $gunz->getHeaderInfo(); - ok $hdr, " got Header info"; - my $uncomp ; - ok $gunz->read($uncomp), " read ok" ; - is $uncomp, $content, " got expected content"; - ok $gunz->close, " closed ok" ; - - return $hdr ; - -} - -{ - title "Check zip header default NAME & MTIME settings" ; - - my $lex = new LexFile my $file1; - - my $content = "hello "; - my $hdr ; - my $mtime ; - - writeFile($file1, $content); - $mtime = (stat($file1))[9]; - # make sure that the zip file isn't created in the same - # second as the input file - sleep 3 ; - $hdr = zipGetHeader($file1, $content); - - is $hdr->{Name}, $file1, " Name is '$file1'"; - is $hdr->{Time}>>1, $mtime>>1, " Time is ok"; - - title "Override Name" ; - - writeFile($file1, $content); - $mtime = (stat($file1))[9]; - sleep 3 ; - $hdr = zipGetHeader($file1, $content, Name => "abcde"); - - is $hdr->{Name}, "abcde", " Name is 'abcde'" ; - is $hdr->{Time} >> 1, $mtime >> 1, " Time is ok"; - - title "Override Time" ; - - writeFile($file1, $content); - my $useTime = time + 2000 ; - $hdr = zipGetHeader($file1, $content, Time => $useTime); - - is $hdr->{Name}, $file1, " Name is '$file1'" ; - is $hdr->{Time} >> 1 , $useTime >> 1 , " Time is $useTime"; - - title "Override Name and Time" ; - - $useTime = time + 5000 ; - writeFile($file1, $content); - $hdr = zipGetHeader($file1, $content, Time => $useTime, Name => "abcde"); - - is $hdr->{Name}, "abcde", " Name is 'abcde'" ; - is $hdr->{Time} >> 1 , $useTime >> 1 , " Time is $useTime"; - - title "Filehandle doesn't have default Name or Time" ; - my $fh = new IO::File "< $file1" - or diag "Cannot open '$file1': $!\n" ; - sleep 3 ; - my $before = time ; - $hdr = zipGetHeader($fh, $content); - my $after = time ; - - ok ! defined $hdr->{Name}, " Name is undef"; - cmp_ok $hdr->{Time} >> 1, '>=', $before >> 1, " Time is ok"; - cmp_ok $hdr->{Time} >> 1, '<=', $after >> 1, " Time is ok"; - - $fh->close; - - title "Buffer doesn't have default Name or Time" ; - my $buffer = $content; - $before = time ; - $hdr = zipGetHeader(\$buffer, $content); - $after = time ; - - ok ! defined $hdr->{Name}, " Name is undef"; - cmp_ok $hdr->{Time} >> 1, '>=', $before >> 1, " Time is ok"; - cmp_ok $hdr->{Time} >> 1, '<=', $after >> 1, " Time is ok"; -} - -for my $stream (0, 1) -{ - for my $zip64 (0, 1) - { - #next if $zip64 && ! $stream; - - for my $method (ZIP_CM_STORE, ZIP_CM_DEFLATE) - { - - title "Stream $stream, Zip64 $zip64, Method $method"; - - my $lex = new LexFile my $file1; - - my $content = "hello "; - #writeFile($file1, $content); - - my $status = zip(\$content => $file1 , - Method => $method, - Stream => $stream, - Zip64 => $zip64); - - ok $status, " zip ok" - or diag $ZipError ; - - my $got ; - if ($stream && $method == ZIP_CM_STORE ) { - #eval ' unzip($file1 => \$got) '; - ok ! unzip($file1 => \$got), " unzip fails"; - like $UnzipError, "/Streamed Stored content not supported/", - " Streamed Stored content not supported"; - next ; - } - - ok unzip($file1 => \$got), " unzip ok" - or diag $UnzipError ; - - is $got, $content, " content ok"; - - my $u = new IO::Uncompress::Unzip $file1 - or diag $ZipError ; - - my $hdr = $u->getHeaderInfo(); - ok $hdr, " got header"; - - is $hdr->{Stream}, $stream, " stream is $stream" ; - is $hdr->{MethodID}, $method, " MethodID is $method" ; - is $hdr->{Zip64}, $zip64, " Zip64 is $zip64" ; - } - } -} - -for my $stream (0, 1) -{ - for my $zip64 (0, 1) - { - next if $zip64 && ! $stream; - for my $method (ZIP_CM_STORE, ZIP_CM_DEFLATE) - { - title "Stream $stream, Zip64 $zip64, Method $method"; - - my $file1; - my $file2; - my $zipfile; - my $lex = new LexFile $file1, $file2, $zipfile; - - my $content1 = "hello "; - writeFile($file1, $content1); - - my $content2 = "goodbye "; - writeFile($file2, $content2); - - my %content = ( $file1 => $content1, - $file2 => $content2, - ); - - ok zip([$file1, $file2] => $zipfile , Method => $method, - Zip64 => $zip64, - Stream => $stream), " zip ok" - or diag $ZipError ; - - for my $file ($file1, $file2) - { - my $got ; - if ($stream && $method == ZIP_CM_STORE ) { - #eval ' unzip($zipfile => \$got) '; - ok ! unzip($zipfile => \$got, Name => $file), " unzip fails"; - like $UnzipError, "/Streamed Stored content not supported/", - " Streamed Stored content not supported"; - next ; - } - - ok unzip($zipfile => \$got, Name => $file), " unzip $file ok" - or diag $UnzipError ; - - is $got, $content{$file}, " content ok"; - } - } - } -} - -# TODO add more error cases - diff --git a/ext/IO-Compress/t/105oneshot-zip.t b/ext/IO-Compress/t/105oneshot-zip.t deleted file mode 100644 index e236fc66fa..0000000000 --- a/ext/IO-Compress/t/105oneshot-zip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "oneshot.pl" ; -run(); diff --git a/ext/IO-Compress/t/106prime-bzip2.t b/ext/IO-Compress/t/106prime-bzip2.t deleted file mode 100644 index d5a0d98fff..0000000000 --- a/ext/IO-Compress/t/106prime-bzip2.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "prime.pl" ; -run(); diff --git a/ext/IO-Compress/t/106prime-deflate.t b/ext/IO-Compress/t/106prime-deflate.t deleted file mode 100644 index 0ef9bd8834..0000000000 --- a/ext/IO-Compress/t/106prime-deflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "prime.pl" ; -run(); diff --git a/ext/IO-Compress/t/106prime-gzip.t b/ext/IO-Compress/t/106prime-gzip.t deleted file mode 100644 index b6ab10e6d2..0000000000 --- a/ext/IO-Compress/t/106prime-gzip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "prime.pl" ; -run(); diff --git a/ext/IO-Compress/t/106prime-rawdeflate.t b/ext/IO-Compress/t/106prime-rawdeflate.t deleted file mode 100644 index 4c81f7c605..0000000000 --- a/ext/IO-Compress/t/106prime-rawdeflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "prime.pl" ; -run(); diff --git a/ext/IO-Compress/t/106prime-zip.t b/ext/IO-Compress/t/106prime-zip.t deleted file mode 100644 index 702c40128a..0000000000 --- a/ext/IO-Compress/t/106prime-zip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "prime.pl" ; -run(); diff --git a/ext/IO-Compress/t/107multi-bzip2.t b/ext/IO-Compress/t/107multi-bzip2.t deleted file mode 100644 index 0e7f5dbef3..0000000000 --- a/ext/IO-Compress/t/107multi-bzip2.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "multi.pl" ; -run(); diff --git a/ext/IO-Compress/t/107multi-deflate.t b/ext/IO-Compress/t/107multi-deflate.t deleted file mode 100644 index 397869bc92..0000000000 --- a/ext/IO-Compress/t/107multi-deflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "multi.pl" ; -run(); diff --git a/ext/IO-Compress/t/107multi-gzip.t b/ext/IO-Compress/t/107multi-gzip.t deleted file mode 100644 index 10922ed0da..0000000000 --- a/ext/IO-Compress/t/107multi-gzip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "multi.pl" ; -run(); diff --git a/ext/IO-Compress/t/107multi-rawdeflate.t b/ext/IO-Compress/t/107multi-rawdeflate.t deleted file mode 100644 index 374cb67831..0000000000 --- a/ext/IO-Compress/t/107multi-rawdeflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "multi.pl" ; -run(); diff --git a/ext/IO-Compress/t/107multi-zip.t b/ext/IO-Compress/t/107multi-zip.t deleted file mode 100644 index fea653fbf6..0000000000 --- a/ext/IO-Compress/t/107multi-zip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "multi.pl" ; -run(); diff --git a/ext/IO-Compress/t/108anyunc-bzip2.t b/ext/IO-Compress/t/108anyunc-bzip2.t deleted file mode 100644 index 4b981e6806..0000000000 --- a/ext/IO-Compress/t/108anyunc-bzip2.t +++ /dev/null @@ -1,29 +0,0 @@ -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 IO::Uncompress::AnyUncompress qw($AnyUncompressError) ; - -use IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub getClass -{ - 'AnyUncompress'; -} - - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "any.pl" ; -run(); diff --git a/ext/IO-Compress/t/108anyunc-deflate.t b/ext/IO-Compress/t/108anyunc-deflate.t deleted file mode 100644 index ed5e6b5efe..0000000000 --- a/ext/IO-Compress/t/108anyunc-deflate.t +++ /dev/null @@ -1,29 +0,0 @@ -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 IO::Uncompress::AnyUncompress qw($AnyUncompressError) ; - -use IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub getClass -{ - 'AnyUncompress'; -} - - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "any.pl" ; -run(); diff --git a/ext/IO-Compress/t/108anyunc-gzip.t b/ext/IO-Compress/t/108anyunc-gzip.t deleted file mode 100644 index bac6a6a9d0..0000000000 --- a/ext/IO-Compress/t/108anyunc-gzip.t +++ /dev/null @@ -1,29 +0,0 @@ -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 IO::Uncompress::AnyUncompress qw($AnyUncompressError) ; - -use IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub getClass -{ - 'AnyUncompress'; -} - - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "any.pl" ; -run(); diff --git a/ext/IO-Compress/t/108anyunc-rawdeflate.t b/ext/IO-Compress/t/108anyunc-rawdeflate.t deleted file mode 100644 index 7d85dada9a..0000000000 --- a/ext/IO-Compress/t/108anyunc-rawdeflate.t +++ /dev/null @@ -1,29 +0,0 @@ -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 IO::Uncompress::AnyUncompress qw($AnyUncompressError) ; - -use IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub getClass -{ - 'AnyUncompress'; -} - - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "any.pl" ; -run(); diff --git a/ext/IO-Compress/t/108anyunc-transparent.t b/ext/IO-Compress/t/108anyunc-transparent.t deleted file mode 100644 index 687b1f5cd2..0000000000 --- a/ext/IO-Compress/t/108anyunc-transparent.t +++ /dev/null @@ -1,72 +0,0 @@ -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 => 15 + $extra ; - - use_ok('IO::Uncompress::AnyUncompress', qw($AnyUncompressError)) ; - -} - -{ - - my $string = <<EOM; -This is not compressed data -EOM - - my $buffer = $string ; - - for my $file (0, 1) - { - title "AnyUncompress with Non-compressed data (File $file)" ; - - my $lex = new LexFile my $output; - my $input ; - - if ($file) { - writeFile($output, $buffer); - $input = $output; - } - else { - $input = \$buffer; - } - - - my $unc ; - my $keep = $buffer ; - $unc = new IO::Uncompress::AnyUncompress $input, -Transparent => 0 ; - ok ! $unc," no AnyUncompress object when -Transparent => 0" ; - is $buffer, $keep ; - - $buffer = $keep ; - $unc = new IO::Uncompress::AnyUncompress \$buffer, -Transparent => 1 ; - ok $unc, " AnyUncompress object when -Transparent => 1" ; - - my $uncomp ; - ok $unc->read($uncomp) > 0 ; - ok $unc->eof() ; - #ok $unc->type eq $Type; - - is $uncomp, $string ; - } -} - -1; diff --git a/ext/IO-Compress/t/108anyunc-zip.t b/ext/IO-Compress/t/108anyunc-zip.t deleted file mode 100644 index 72e015a6a1..0000000000 --- a/ext/IO-Compress/t/108anyunc-zip.t +++ /dev/null @@ -1,29 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - @INC = ("../lib", "lib/compress"); - } -} - -use lib 't/compress'; -use strict; -use warnings; - -use IO::Uncompress::AnyUncompress qw($AnyUncompressError) ; - -use IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub getClass -{ - 'AnyUncompress'; -} - - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "any.pl" ; -run(); diff --git a/ext/IO-Compress/t/109merge-deflate.t b/ext/IO-Compress/t/109merge-deflate.t deleted file mode 100644 index a489f354d3..0000000000 --- a/ext/IO-Compress/t/109merge-deflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "merge.pl" ; -run(); diff --git a/ext/IO-Compress/t/109merge-gzip.t b/ext/IO-Compress/t/109merge-gzip.t deleted file mode 100644 index 3041a99420..0000000000 --- a/ext/IO-Compress/t/109merge-gzip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "merge.pl" ; -run(); diff --git a/ext/IO-Compress/t/109merge-rawdeflate.t b/ext/IO-Compress/t/109merge-rawdeflate.t deleted file mode 100644 index 2c9663726e..0000000000 --- a/ext/IO-Compress/t/109merge-rawdeflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "merge.pl" ; -run(); diff --git a/ext/IO-Compress/t/109merge-zip.t b/ext/IO-Compress/t/109merge-zip.t deleted file mode 100644 index 74adf09bf9..0000000000 --- a/ext/IO-Compress/t/109merge-zip.t +++ /dev/null @@ -1,24 +0,0 @@ -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 skip_all => "not implemented yet"; - - -use IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "merge.pl" ; -run(); diff --git a/ext/IO-Compress/t/110encode-bzip2.t b/ext/IO-Compress/t/110encode-bzip2.t deleted file mode 100644 index 974dc8f24a..0000000000 --- a/ext/IO-Compress/t/110encode-bzip2.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Bzip2 qw($Bzip2Error) ; -use IO::Uncompress::Bunzip2 qw($Bunzip2Error) ; - -sub identify -{ - 'IO::Compress::Bzip2'; -} - -require "encode.pl" ; -run(); diff --git a/ext/IO-Compress/t/110encode-deflate.t b/ext/IO-Compress/t/110encode-deflate.t deleted file mode 100644 index a1f93a9512..0000000000 --- a/ext/IO-Compress/t/110encode-deflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Deflate qw($DeflateError) ; -use IO::Uncompress::Inflate qw($InflateError) ; - -sub identify -{ - 'IO::Compress::Deflate'; -} - -require "encode.pl" ; -run(); diff --git a/ext/IO-Compress/t/110encode-gzip.t b/ext/IO-Compress/t/110encode-gzip.t deleted file mode 100644 index d40c36e905..0000000000 --- a/ext/IO-Compress/t/110encode-gzip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Gzip qw($GzipError) ; -use IO::Uncompress::Gunzip qw($GunzipError) ; - -sub identify -{ - 'IO::Compress::Gzip'; -} - -require "encode.pl" ; -run(); diff --git a/ext/IO-Compress/t/110encode-rawdeflate.t b/ext/IO-Compress/t/110encode-rawdeflate.t deleted file mode 100644 index 58fa7417b1..0000000000 --- a/ext/IO-Compress/t/110encode-rawdeflate.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::RawDeflate qw($RawDeflateError) ; -use IO::Uncompress::RawInflate qw($RawInflateError) ; - -sub identify -{ - 'IO::Compress::RawDeflate'; -} - -require "encode.pl" ; -run(); diff --git a/ext/IO-Compress/t/110encode-zip.t b/ext/IO-Compress/t/110encode-zip.t deleted file mode 100644 index 80e99eec58..0000000000 --- a/ext/IO-Compress/t/110encode-zip.t +++ /dev/null @@ -1,21 +0,0 @@ -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 IO::Compress::Zip qw($ZipError) ; -use IO::Uncompress::Unzip qw($UnzipError) ; - -sub identify -{ - 'IO::Compress::Zip'; -} - -require "encode.pl" ; -run(); diff --git a/ext/IO-Compress/t/999pod.t b/ext/IO-Compress/t/999pod.t deleted file mode 100644 index 760f737716..0000000000 --- a/ext/IO-Compress/t/999pod.t +++ /dev/null @@ -1,16 +0,0 @@ -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/IO-Compress/t/compress/CompTestUtils.pm b/ext/IO-Compress/t/compress/CompTestUtils.pm deleted file mode 100644 index cb63d6274c..0000000000 --- a/ext/IO-Compress/t/compress/CompTestUtils.pm +++ /dev/null @@ -1,684 +0,0 @@ -package CompTestUtils; - -package main ; - -use strict ; -use warnings; -use bytes; - -#use lib qw(t t/compress); - -use Carp ; -#use Test::More ; - - - -sub title -{ - #diag "" ; - ok 1, $_[0] ; - #diag "" ; -} - -sub like_eval -{ - like $@, @_ ; -} - -{ - package LexFile ; - - our ($index); - $index = '00000'; - - sub new - { - my $self = shift ; - foreach (@_) - { - # autogenerate the name unless if none supplied - $_ = "tst" . $index ++ . ".tmp" - unless defined $_; - } - chmod 0777, @_; - for (@_) { 1 while unlink $_ } ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - chmod 0777, @{ $self } ; - for (@$self) { 1 while unlink $_ } ; - } - -} - -{ - package LexDir ; - - use File::Path; - sub new - { - my $self = shift ; - foreach (@_) { rmtree $_ } - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - foreach (@$self) { rmtree $_ } - } -} -sub readFile -{ - my $f = shift ; - - my @strings ; - - if (IO::Compress::Base::Common::isaFilehandle($f)) - { - my $pos = tell($f); - seek($f, 0,0); - @strings = <$f> ; - seek($f, 0, $pos); - } - else - { - open (F, "<$f") - or croak "Cannot open $f: $!\n" ; - binmode F; - @strings = <F> ; - close F ; - } - - return @strings if wantarray ; - return join "", @strings ; -} - -sub touch -{ - foreach (@_) { writeFile($_, '') } -} - -sub writeFile -{ - my($filename, @strings) = @_ ; - 1 while unlink $filename ; - open (F, ">$filename") - or croak "Cannot open $filename: $!\n" ; - binmode F; - foreach (@strings) { - no warnings ; - print F $_ ; - } - close F ; -} - -sub GZreadFile -{ - my ($filename) = shift ; - - my ($uncomp) = "" ; - my $line = "" ; - my $fil = gzopen($filename, "rb") - or croak "Cannopt open '$filename': $Compress::Zlib::gzerrno" ; - - $uncomp .= $line - while $fil->gzread($line) > 0; - - $fil->gzclose ; - return $uncomp ; -} - -sub hexDump -{ - my $d = shift ; - - if (IO::Compress::Base::Common::isaFilehandle($d)) - { - $d = readFile($d); - } - elsif (IO::Compress::Base::Common::isaFilename($d)) - { - $d = readFile($d); - } - else - { - $d = $$d ; - } - - my $offset = 0 ; - - $d = '' unless defined $d ; - #while (read(STDIN, $data, 16)) { - while (my $data = substr($d, 0, 16)) { - substr($d, 0, 16) = '' ; - printf "# %8.8lx ", $offset; - $offset += 16; - - my @array = unpack('C*', $data); - foreach (@array) { - printf('%2.2x ', $_); - } - print " " x (16 - @array) - if @array < 16 ; - $data =~ tr/\0-\37\177-\377/./; - print " $data\n"; - } - -} - -sub readHeaderInfo -{ - my $name = shift ; - my %opts = @_ ; - - my $string = <<EOM; -some text -EOM - - ok my $x = new IO::Compress::Gzip $name, %opts - or diag "GzipError is $IO::Compress::Gzip::GzipError" ; - ok $x->write($string) ; - ok $x->close ; - - #is GZreadFile($name), $string ; - - ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0 - or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; - ok my $hdr = $gunz->getHeaderInfo(); - my $uncomp ; - ok $gunz->read($uncomp) ; - ok $uncomp eq $string; - ok $gunz->close ; - - return $hdr ; -} - -sub cmpFile -{ - my ($filename, $uue) = @_ ; - return readFile($filename) eq unpack("u", $uue) ; -} - -#sub isRawFormat -#{ -# my $class = shift; -# # TODO -- add Lzma here? -# my %raw = map { $_ => 1 } qw( RawDeflate ); -# -# return defined $raw{$class}; -#} - - - -my %TOP = ( - 'IO::Uncompress::AnyInflate' => { Inverse => 'IO::Compress::Gzip', - Error => 'AnyInflateError', - TopLevel => 'anyinflate', - Raw => 0, - }, - - 'IO::Uncompress::AnyUncompress' => { Inverse => 'IO::Compress::Gzip', - Error => 'AnyUncompressError', - TopLevel => 'anyuncompress', - Raw => 0, - }, - - 'IO::Compress::Gzip' => { Inverse => 'IO::Uncompress::Gunzip', - Error => 'GzipError', - TopLevel => 'gzip', - Raw => 0, - }, - 'IO::Uncompress::Gunzip' => { Inverse => 'IO::Compress::Gzip', - Error => 'GunzipError', - TopLevel => 'gunzip', - Raw => 0, - }, - - 'IO::Compress::Deflate' => { Inverse => 'IO::Uncompress::Inflate', - Error => 'DeflateError', - TopLevel => 'deflate', - Raw => 0, - }, - 'IO::Uncompress::Inflate' => { Inverse => 'IO::Compress::Deflate', - Error => 'InflateError', - TopLevel => 'inflate', - Raw => 0, - }, - - 'IO::Compress::RawDeflate' => { Inverse => 'IO::Uncompress::RawInflate', - Error => 'RawDeflateError', - TopLevel => 'rawdeflate', - Raw => 1, - }, - 'IO::Uncompress::RawInflate' => { Inverse => 'IO::Compress::RawDeflate', - Error => 'RawInflateError', - TopLevel => 'rawinflate', - Raw => 1, - }, - - 'IO::Compress::Zip' => { Inverse => 'IO::Uncompress::Unzip', - Error => 'ZipError', - TopLevel => 'zip', - Raw => 0, - }, - 'IO::Uncompress::Unzip' => { Inverse => 'IO::Compress::Zip', - Error => 'UnzipError', - TopLevel => 'unzip', - Raw => 0, - }, - - 'IO::Compress::Bzip2' => { Inverse => 'IO::Uncompress::Bunzip2', - Error => 'Bzip2Error', - TopLevel => 'bzip2', - Raw => 0, - }, - 'IO::Uncompress::Bunzip2' => { Inverse => 'IO::Compress::Bzip2', - Error => 'Bunzip2Error', - TopLevel => 'bunzip2', - Raw => 0, - }, - - 'IO::Compress::Lzop' => { Inverse => 'IO::Uncompress::UnLzop', - Error => 'LzopError', - TopLevel => 'lzop', - Raw => 0, - }, - 'IO::Uncompress::UnLzop' => { Inverse => 'IO::Compress::Lzop', - Error => 'UnLzopError', - TopLevel => 'unlzop', - Raw => 0, - }, - - 'IO::Compress::Lzf' => { Inverse => 'IO::Uncompress::UnLzf', - Error => 'LzfError', - TopLevel => 'lzf', - Raw => 0, - }, - 'IO::Uncompress::UnLzf' => { Inverse => 'IO::Compress::Lzf', - Error => 'UnLzfError', - TopLevel => 'unlzf', - Raw => 0, - }, - - 'IO::Compress::Lzma' => { Inverse => 'IO::Uncompress::UnLzma', - Error => 'LzmaError', - TopLevel => 'lzma', - Raw => 1, - }, - 'IO::Uncompress::UnLzma' => { Inverse => 'IO::Compress::Lzma', - Error => 'UnLzmaError', - TopLevel => 'unlzma', - Raw => 1, - }, - - 'IO::Compress::Xz' => { Inverse => 'IO::Uncompress::UnXz', - Error => 'XzError', - TopLevel => 'xz', - Raw => 0, - }, - 'IO::Uncompress::UnXz' => { Inverse => 'IO::Compress::Xz', - Error => 'UnXzError', - TopLevel => 'unxz', - Raw => 0, - }, - - 'IO::Compress::PPMd' => { Inverse => 'IO::Uncompress::UnPPMd', - Error => 'PPMdError', - TopLevel => 'ppmd', - Raw => 0, - }, - 'IO::Uncompress::UnPPMd' => { Inverse => 'IO::Compress::PPMd', - Error => 'UnPPMdError', - TopLevel => 'unppmd', - Raw => 0, - }, - - 'IO::Compress::DummyComp' => { Inverse => 'IO::Uncompress::DummyUnComp', - Error => 'DummyCompError', - TopLevel => 'dummycomp', - Raw => 0, - }, - 'IO::Uncompress::DummyUnComp' => { Inverse => 'IO::Compress::DummyComp', - Error => 'DummyUnCompError', - TopLevel => 'dummyunComp', - Raw => 0, - }, -); - - -for my $key (keys %TOP) -{ - no strict; - no warnings; - $TOP{$key}{Error} = \${ $key . '::' . $TOP{$key}{Error} }; - $TOP{$key}{TopLevel} = $key . '::' . $TOP{$key}{TopLevel} ; - - # Silence used once warning in really old perl - my $dummy = \${ $key . '::' . $TOP{$key}{Error} }; - - #$TOP{$key . "::" . $TOP{$key}{TopLevel} } = $TOP{$key}; -} - -sub uncompressBuffer -{ - my $compWith = shift ; - my $buffer = shift ; - - - my $out ; - my $obj = $TOP{$compWith}{Inverse}->new( \$buffer, -Append => 1); - 1 while $obj->read($out) > 0 ; - return $out ; - -} - - -sub getInverse -{ - my $class = shift ; - - return $TOP{$class}{Inverse}; -} - -sub getErrorRef -{ - my $class = shift ; - - return $TOP{$class}{Error}; -} - -sub getTopFuncRef -{ - my $class = shift ; - - die "Cannot find $class" - if ! defined $TOP{$class}{TopLevel}; - return \&{ $TOP{$class}{TopLevel} } ; -} - -sub getTopFuncName -{ - my $class = shift ; - - return $TOP{$class}{TopLevel} ; -} - -sub compressBuffer -{ - my $compWith = shift ; - my $buffer = shift ; - - - my $out ; - die "Cannot find $compWith" - if ! defined $TOP{$compWith}{Inverse}; - my $obj = $TOP{$compWith}{Inverse}->new( \$out); - $obj->write($buffer) ; - $obj->close(); - return $out ; -} - -our ($AnyUncompressError); -BEGIN -{ - eval ' use IO::Uncompress::AnyUncompress qw($AnyUncompressError); '; -} - -sub anyUncompress -{ - my $buffer = shift ; - my $already = shift; - - my @opts = (); - if (ref $buffer && ref $buffer eq 'ARRAY') - { - @opts = @$buffer; - $buffer = shift @opts; - } - - if (ref $buffer) - { - croak "buffer is undef" unless defined $$buffer; - croak "buffer is empty" unless length $$buffer; - - } - - - my $data ; - if (IO::Compress::Base::Common::isaFilehandle($buffer)) - { - $data = readFile($buffer); - } - elsif (IO::Compress::Base::Common::isaFilename($buffer)) - { - $data = readFile($buffer); - } - else - { - $data = $$buffer ; - } - - if (defined $already && length $already) - { - - my $got = substr($data, 0, length($already)); - substr($data, 0, length($already)) = ''; - - is $got, $already, ' Already OK' ; - } - - my $out = ''; - my $o = new IO::Uncompress::AnyUncompress \$data, - Append => 1, - Transparent => 0, - RawInflate => 1, - @opts - or croak "Cannot open buffer/file: $AnyUncompressError" ; - - 1 while $o->read($out) > 0 ; - - croak "Error uncompressing -- " . $o->error() - if $o->error() ; - - return $out ; - -} - -sub getHeaders -{ - my $buffer = shift ; - my $already = shift; - - my @opts = (); - if (ref $buffer && ref $buffer eq 'ARRAY') - { - @opts = @$buffer; - $buffer = shift @opts; - } - - if (ref $buffer) - { - croak "buffer is undef" unless defined $$buffer; - croak "buffer is empty" unless length $$buffer; - - } - - - my $data ; - if (IO::Compress::Base::Common::isaFilehandle($buffer)) - { - $data = readFile($buffer); - } - elsif (IO::Compress::Base::Common::isaFilename($buffer)) - { - $data = readFile($buffer); - } - else - { - $data = $$buffer ; - } - - if (defined $already && length $already) - { - - my $got = substr($data, 0, length($already)); - substr($data, 0, length($already)) = ''; - - is $got, $already, ' Already OK' ; - } - - my $out = ''; - my $o = new IO::Uncompress::AnyUncompress \$data, - MultiStream => 1, - Append => 1, - Transparent => 0, - RawInflate => 1, - @opts - or croak "Cannot open buffer/file: $AnyUncompressError" ; - - 1 while $o->read($out) > 0 ; - - croak "Error uncompressing -- " . $o->error() - if $o->error() ; - - return ($o->getHeaderInfo()) ; - -} - -sub mkComplete -{ - my $class = shift ; - my $data = shift; - my $Error = getErrorRef($class); - - my $buffer ; - my %params = (); - - if ($class eq 'IO::Compress::Gzip') { - %params = ( - Name => "My name", - Comment => "a comment", - ExtraField => ['ab' => "extra"], - HeaderCRC => 1); - } - elsif ($class eq 'IO::Compress::Zip'){ - %params = ( - Name => "My name", - Comment => "a comment", - ZipComment => "last comment", - exTime => [100, 200, 300], - ExtraFieldLocal => ["ab" => "extra1"], - ExtraFieldCentral => ["cd" => "extra2"], - ); - } - - my $z = new $class( \$buffer, %params) - or croak "Cannot create $class object: $$Error"; - $z->write($data); - $z->close(); - - my $unc = getInverse($class); - anyUncompress(\$buffer) eq $data - or die "bad bad bad"; - my $u = new $unc( \$buffer); - my $info = $u->getHeaderInfo() ; - - - return wantarray ? ($info, $buffer) : $buffer ; -} - -sub mkErr -{ - my $string = shift ; - my ($dummy, $file, $line) = caller ; - -- $line ; - - $file = quotemeta($file); - - #return "/$string\\s+at $file line $line/" if $] >= 5.006 ; - return "/$string\\s+at /" ; -} - -sub mkEvalErr -{ - my $string = shift ; - - #return "/$string\\s+at \\(eval /" if $] > 5.006 ; - return "/$string\\s+at /" ; -} - -sub dumpObj -{ - my $obj = shift ; - - my ($dummy, $file, $line) = caller ; - - if (@_) - { - print "#\n# dumpOBJ from $file line $line @_\n" ; - } - else - { - print "#\n# dumpOBJ from $file line $line \n" ; - } - - my $max = 0 ;; - foreach my $k (keys %{ *$obj }) - { - $max = length $k if length $k > $max ; - } - - foreach my $k (sort keys %{ *$obj }) - { - my $v = $obj->{$k} ; - $v = '-undef-' unless defined $v; - my $pad = ' ' x ($max - length($k) + 2) ; - print "# $k$pad: [$v]\n"; - } - print "#\n" ; -} - - -sub getMultiValues -{ - my $class = shift ; - - return (0,0) if $class =~ /lzf/i; - return (1,0); -} - - -sub gotScalarUtilXS -{ - eval ' use Scalar::Util "dualvar" '; - return $@ ? 0 : 1 ; -} - -package CompTestUtils; - -1; -__END__ - t/Test/Builder.pm - t/Test/More.pm - t/Test/Simple.pm - t/compress/CompTestUtils.pm - t/compress/any.pl - t/compress/anyunc.pl - t/compress/destroy.pl - t/compress/generic.pl - t/compress/merge.pl - t/compress/multi.pl - t/compress/newtied.pl - t/compress/oneshot.pl - t/compress/prime.pl - t/compress/tied.pl - t/compress/truncate.pl - t/compress/zlib-generic.plParsing config.in... -Building Zlib enabled -Auto Detect Gzip OS Code.. -Setting Gzip OS Code to 3 [Unix/Default] -Looks Good. diff --git a/ext/IO-Compress/t/compress/any.pl b/ext/IO-Compress/t/compress/any.pl deleted file mode 100644 index d95766b0a9..0000000000 --- a/ext/IO-Compress/t/compress/any.pl +++ /dev/null @@ -1,98 +0,0 @@ - -use lib 't'; - -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 => 48 + $extra ; - -} - -sub run -{ - my $CompressClass = identify(); - my $AnyClass = getClass(); - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - my $AnyConstruct = "IO::Uncompress::${AnyClass}" ; - no strict 'refs'; - my $AnyError = \${ "IO::Uncompress::${AnyClass}::${AnyClass}Error" }; - - for my $trans ( 0, 1 ) - { - for my $file ( 0, 1 ) - { - title "$AnyClass(Transparent => $trans, File=>$file) with $CompressClass" ; - my $string = "some text" x 100 ; - - my $buffer ; - my $x = new $CompressClass(\$buffer) ; - ok $x, " create $CompressClass object" ; - ok $x->write($string), " write to object" ; - ok $x->close, " close ok" ; - - my $lex = new LexFile my $output; - my $input ; - - if ($file) { - writeFile($output, $buffer); - $input = $output; - } - else { - $input = \$buffer; - } - - { - my $unc = new $AnyConstruct $input, Transparent => $trans, - RawInflate => 1, - Append => 1 ; - - ok $unc, " Created $AnyClass object" - or print "# $$AnyError\n"; - my $uncomp ; - 1 while $unc->read($uncomp) > 0 ; - #ok $unc->read($uncomp) > 0 - # or print "# $$AnyError\n"; - my $y; - is $unc->read($y, 1), 0, " at eof" ; - ok $unc->eof(), " at eof" ; - #ok $unc->type eq $Type; - - is $uncomp, $string, " expected output" ; - } - - { - my $unc = new $AnyConstruct $input, Transparent => $trans, - RawInflate => 1, - Append => 1 ; - - ok $unc, " Created $AnyClass object" - or print "# $$AnyError\n"; - my $uncomp ; - 1 while $unc->read($uncomp, 100) > 0 ; - #ok $unc->read($uncomp) > 0 - # or print "# $$AnyError\n"; - my $y; - is $unc->read($y, 1), 0, " at eof" ; - ok $unc->eof(), " at eof" ; - #ok $unc->type eq $Type; - - is $uncomp, $string, " expected output" ; - } - } - } -} - -1; diff --git a/ext/IO-Compress/t/compress/anyunc.pl b/ext/IO-Compress/t/compress/anyunc.pl deleted file mode 100644 index 2860e2571c..0000000000 --- a/ext/IO-Compress/t/compress/anyunc.pl +++ /dev/null @@ -1,93 +0,0 @@ - -use lib 't'; - -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 => 36 + $extra ; -} - -sub run -{ - my $CompressClass = identify(); - my $AnyClass = getClass(); - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - my $AnyConstruct = "IO::Uncompress::${AnyClass}" ; - no strict refs; - my $AnyError = \${ "IO::Uncompress::${AnyClass}::${AnyClass}Error" }; - - for my $trans ( 0, 1 ) - { - for my $file ( 0, 1 ) - { - title "$AnyClass(Transparent => $trans, File=>$file) with $CompressClass" ; - my $string = "some text" x 100 ; - - my $buffer ; - my $x = new $CompressClass(\$buffer) ; - ok $x, " create $CompressClass object" ; - ok $x->write($string), " write to object" ; - ok $x->close, " close ok" ; - - my $lex = new LexFile my $output; - my $input ; - - if ($file) { - writeFile($output, $buffer); - $input = $output; - } - else { - $input = \$buffer; - } - - { - my $unc = new $AnyConstruct $input, Transparent => $trans - Append => 1 ; - - ok $unc, " Created $AnyClass object" - or print "# $$AnyError\n"; - my $uncomp ; - 1 while $unc->read($uncomp) > 0 ; - #ok $unc->read($uncomp) > 0 - # or print "# $$AnyError\n"; - my $y; - is $unc->read($y, 1), 0, " at eof" ; - ok $unc->eof(), " at eof" ; - #ok $unc->type eq $Type; - - is $uncomp, $string, " expected output" ; - } - - { - my $unc = new $AnyConstruct $input, Transparent => $trans, - Append =>1 ; - - ok $unc, " Created $AnyClass object" - or print "# $$AnyError\n"; - my $uncomp ; - 1 while $unc->read($uncomp, 10) > 0 ; - my $y; - is $unc->read($y, 1), 0, " at eof" ; - ok $unc->eof(), " at eof" ; - #ok $unc->type eq $Type; - - is $uncomp, $string, " expected output" ; - } - } - } -} - -1; diff --git a/ext/IO-Compress/t/compress/destroy.pl b/ext/IO-Compress/t/compress/destroy.pl deleted file mode 100644 index 186520df16..0000000000 --- a/ext/IO-Compress/t/compress/destroy.pl +++ /dev/null @@ -1,115 +0,0 @@ - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use CompTestUtils; - -BEGIN -{ - plan(skip_all => "Destroy not supported in Perl $]") - if $] == 5.008 || ( $] >= 5.005 && $] < 5.006) ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 15 + $extra ; - - use_ok('IO::File') ; -} - -sub run -{ - - my $CompressClass = identify(); - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - title "Testing $CompressClass"; - - { - # Check that the class destructor will call close - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - - { - ok my $x = new $CompressClass $name, -AutoClose => 1 ; - - ok $x->write($hello) ; - } - - is anyUncompress($name), $hello ; - } - - { - # Tied filehandle destructor - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - my $fh = new IO::File "> $name" ; - - { - ok my $x = new $CompressClass $fh, -AutoClose => 1 ; - - $x->write($hello) ; - } - - ok anyUncompress($name) eq $hello ; - } - - { - title "Testing DESTROY doesn't clobber \$! etc "; - - my $lex = new LexFile my $name ; - - my $out; - my $result; - - { - ok my $z = new $CompressClass($name); - $z->write("abc") ; - $! = 22 ; - - cmp_ok $!, '==', 22, ' $! is 22'; - } - - cmp_ok $!, '==', 22, " \$! has not been changed by $CompressClass destructor"; - - - { - my $uncomp; - ok my $x = new $UncompressClass($name, -Append => 1) ; - - my $len ; - 1 while ($len = $x->read($result)) > 0 ; - - $! = 22 ; - - cmp_ok $!, '==', 22, ' $! is 22'; - } - - cmp_ok $!, '==', 22, " \$! has not been changed by $UncompressClass destructor"; - - is $result, "abc", " Got uncompressed content ok"; - - } -} - -1; diff --git a/ext/IO-Compress/t/compress/encode.pl b/ext/IO-Compress/t/compress/encode.pl deleted file mode 100644 index 142bd08e59..0000000000 --- a/ext/IO-Compress/t/compress/encode.pl +++ /dev/null @@ -1,123 +0,0 @@ - -use strict; -use warnings; -use bytes; - -use Test::More ; -use CompTestUtils; - -BEGIN -{ - plan skip_all => "Encode is not available" - if $] < 5.006 ; - - eval { require Encode; Encode->import(); }; - - plan skip_all => "Encode is not available" - if $@ ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - - my $st = eval { require Test::NoWarnings ; import Test::NoWarnings; 1; }; - $extra = 1 - if $st ; - - plan(tests => 7 + $extra) ; -} - -sub run -{ - my $CompressClass = identify(); - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - - my $string = "\x{df}\x{100}"; - my $encString = Encode::encode_utf8($string); - my $buffer = $encString; - - #for my $from ( qw(filename filehandle buffer) ) - { -# my $input ; -# my $lex = new LexFile my $name ; -# -# -# if ($from eq 'buffer') -# { $input = \$buffer } -# elsif ($from eq 'filename') -# { -# $input = $name ; -# writeFile($name, $buffer); -# } -# elsif ($from eq 'filehandle') -# { -# $input = new IO::File "<$name" ; -# } - - for my $to ( qw(filehandle buffer)) - { - title "OO Mode: To $to, Encode by hand"; - - my $lex2 = new LexFile my $name2 ; - my $output; - my $buffer; - - if ($to eq 'buffer') - { $output = \$buffer } - elsif ($to eq 'filename') - { - $output = $name2 ; - } - elsif ($to eq 'filehandle') - { - $output = new IO::File ">$name2" ; - } - - - my $out ; - my $cs = new $CompressClass($output, AutoClose =>1); - $cs->print($encString); - $cs->close(); - - my $input; - if ($to eq 'buffer') - { $input = \$buffer } - else - { - $input = $name2 ; - } - - my $ucs = new $UncompressClass($input, Append => 1); - my $got; - 1 while $ucs->read($got) > 0 ; - my $decode = Encode::decode_utf8($got); - - - is $string, $decode, " Expected output"; - - - } - } - - { - title "Catch wide characters"; - - my $out; - my $cs = new $CompressClass(\$out); - my $a = "a\xFF\x{100}"; - eval { $cs->syswrite($a) }; - like($@, qr/Wide character in ${CompressClass}::write/, - " wide characters in ${CompressClass}::write"); - eval { syswrite($cs, $a) }; - like($@, qr/Wide character in ${CompressClass}::write/, - " wide characters in ${CompressClass}::write"); - } - -} - - - -1; - diff --git a/ext/IO-Compress/t/compress/generic.pl b/ext/IO-Compress/t/compress/generic.pl deleted file mode 100644 index 54abab0a54..0000000000 --- a/ext/IO-Compress/t/compress/generic.pl +++ /dev/null @@ -1,1590 +0,0 @@ - -use strict; -use warnings; -use bytes; - -use Test::More ; -use CompTestUtils; - -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - -our ($UncompressClass); -BEGIN -{ - # use Test::NoWarnings, if available - my $extra = 0 ; - - my $st = eval { require Test::NoWarnings ; import Test::NoWarnings; 1; }; - $extra = 1 - if $st ; - - plan(tests => 666 + $extra) ; -} - -sub myGZreadFile -{ - my $filename = shift ; - my $init = shift ; - - - my $fil = new $UncompressClass $filename, - -Strict => 0, - -Append => 1 - ; - - my $data = ''; - $data = $init if defined $init ; - 1 while $fil->read($data) > 0; - - $fil->close ; - return $data ; -} - -sub run -{ - my $CompressClass = identify(); - $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - if(1) - { - - title "Testing $CompressClass Errors"; - - # Buffer not writable - eval qq[\$a = new $CompressClass(\\1) ;] ; - like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ; - - my($out, $gz); - - my $x ; - $gz = new $CompressClass(\$x); - - foreach my $name (qw(read readline getc)) - { - eval " \$gz->$name() " ; - like $@, mkEvalErr("^$name Not Available: File opened only for output"); - } - - eval ' $gz->write({})' ; - like $@, mkEvalErr("^${CompressClass}::write: not a scalar reference"); - - eval ' $gz->syswrite("abc", 1, 5)' ; - like $@, mkEvalErr("^${CompressClass}::write: offset outside string"); - - eval ' $gz->syswrite("abc", 1, -4)' ; - like $@, mkEvalErr("^${CompressClass}::write: offset outside string"), "write outside string"; - } - - - { - title "Testing $UncompressClass Errors"; - - my $out = "" ; - - my $lex = new LexFile my $name ; - - ok ! -e $name, " $name does not exist"; - - $a = new $UncompressClass "$name" ; - is $a, undef; - - my $gc ; - my $guz = new $CompressClass(\$gc); - $guz->write("abc") ; - $guz->close(); - - my $x ; - my $gz = new $UncompressClass(\$gc); - - foreach my $name (qw(print printf write)) - { - eval " \$gz->$name() " ; - like $@, mkEvalErr("^$name Not Available: File opened only for intput"); - } - - } - - - { - title "Testing $CompressClass and $UncompressClass"; - - { - my ($a, $x, @x) = ("","","") ; - - # Buffer not a scalar reference - eval qq[\$a = new $CompressClass \\\@x ;] ; - like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref"); - - # Buffer not a scalar reference - eval qq[\$a = new $UncompressClass \\\@x ;] ; - like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref"); - } - - foreach my $Type ( $CompressClass, $UncompressClass) - { - # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate - - my ($a, $x, @x) = ("","","") ; - - # Odd number of parameters - eval qq[\$a = new $Type "abc", -Output ] ; - like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1"); - - # Unknown parameter - eval qq[\$a = new $Type "anc", -Fred => 123 ;] ; - like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred"); - - # no in or out param - eval qq[\$a = new $Type ;] ; - like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter"); - - } - - - { - # write a very simple compressed file - # and read back - #======================================== - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - my $x ; - ok $x = new $CompressClass $name ; - is $x->autoflush(1), 0, "autoflush"; - is $x->autoflush(1), 1, "autoflush"; - ok $x->opened(), "opened"; - - ok $x->write($hello), "write" ; - ok $x->flush(), "flush"; - ok $x->close, "close" ; - ok ! $x->opened(), "! opened"; - } - - { - my $uncomp; - ok my $x = new $UncompressClass $name, -Append => 1 ; - ok $x->opened(), "opened"; - - my $len ; - 1 while ($len = $x->read($uncomp)) > 0 ; - - is $len, 0, "read returned 0" - or diag $$UnError ; - - ok $x->close ; - is $uncomp, $hello ; - ok !$x->opened(), "! opened"; - } - } - - { - # write a very simple compressed file - # and read back - #======================================== - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - my $x ; - ok $x = new $CompressClass $name ; - - is $x->write(''), 0, "Write empty string is ok"; - is $x->write(undef), 0, "Write undef is ok"; - ok $x->write($hello), "Write ok" ; - ok $x->close, "Close ok" ; - } - - { - my $uncomp; - my $x = new $UncompressClass $name ; - ok $x, "creates $UncompressClass $name" ; - - my $data = ''; - $data .= $uncomp while $x->read($uncomp) > 0 ; - - ok $x->close, "close ok" ; - is $data, $hello, "expected output" ; - } - } - - - { - # write a very simple file with using an IO filehandle - # and read back - #======================================== - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - my $fh = new IO::File ">$name" ; - ok $fh, "opened file $name ok"; - my $x = new $CompressClass $fh ; - ok $x, " created $CompressClass $fh" ; - - is $x->fileno(), fileno($fh), "fileno match" ; - is $x->write(''), 0, "Write empty string is ok"; - is $x->write(undef), 0, "Write undef is ok"; - ok $x->write($hello), "write ok" ; - ok $x->flush(), "flush"; - ok $x->close,"close" ; - $fh->close() ; - } - - my $uncomp; - { - my $x ; - ok my $fh1 = new IO::File "<$name" ; - ok $x = new $UncompressClass $fh1, -Append => 1 ; - ok $x->fileno() == fileno $fh1 ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close ; - } - - ok $hello eq $uncomp ; - } - - { - # write a very simple file with using a glob filehandle - # and read back - #======================================== - - - my $lex = new LexFile my $name ; - #my $name = "/tmp/fred"; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - title "$CompressClass: Input from typeglob filehandle"; - ok open FH, ">$name" ; - - my $x = new $CompressClass *FH ; - ok $x, " create $CompressClass" ; - - is $x->fileno(), fileno(*FH), " fileno" ; - is $x->write(''), 0, " Write empty string is ok"; - is $x->write(undef), 0, " Write undef is ok"; - ok $x->write($hello), " Write ok" ; - ok $x->flush(), " Flush"; - ok $x->close, " Close" ; - close FH; - } - - - my $uncomp; - { - title "$UncompressClass: Input from typeglob filehandle, append output"; - my $x ; - ok open FH, "<$name" ; - ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0 - or diag $$UnError ; - is $x->fileno(), fileno FH, " fileno ok" ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close, " close" ; - } - - is $uncomp, $hello, " expected output" ; - } - - { - my $lex = new LexFile my $name ; - #my $name = "/tmp/fred"; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - title "Outout to stdout via '-'" ; - - open(SAVEOUT, ">&STDOUT"); - my $dummy = fileno SAVEOUT; - open STDOUT, ">$name" ; - - my $x = new $CompressClass '-' ; - $x->write($hello); - $x->close; - - open(STDOUT, ">&SAVEOUT"); - - ok 1, " wrote to stdout" ; - } - is myGZreadFile($name), $hello, " wrote OK"; - #hexDump($name); - - { - title "Input from stdin via filename '-'"; - - my $x ; - my $uncomp ; - my $stdinFileno = fileno(STDIN); - # open below doesn't return 1 sometines on XP - open(SAVEIN, "<&STDIN"); - ok open(STDIN, "<$name"), " redirect STDIN"; - my $dummy = fileno SAVEIN; - $x = new $UncompressClass '-', Append => 1, Transparent => 0 - or diag $$UnError ; - ok $x, " created object" ; - is $x->fileno(), $stdinFileno, " fileno ok" ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close, " close" ; - open(STDIN, "<&SAVEIN"); - is $uncomp, $hello, " expected output" ; - } - } - - { - # write a compressed file to memory - # and read back - #======================================== - - #my $name = "test.gz" ; - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - my $buffer ; - { - my $x ; - ok $x = new $CompressClass(\$buffer) ; - - ok ! defined $x->autoflush(1) ; - ok ! defined $x->autoflush(1) ; - ok ! defined $x->fileno() ; - is $x->write(''), 0, "Write empty string is ok"; - is $x->write(undef), 0, "Write undef is ok"; - ok $x->write($hello) ; - ok $x->flush(); - ok $x->close ; - - writeFile($name, $buffer) ; - #is anyUncompress(\$buffer), $hello, " any ok"; - } - - my $keep = $buffer ; - my $uncomp; - { - my $x ; - ok $x = new $UncompressClass(\$buffer, Append => 1) ; - - ok ! defined $x->autoflush(1) ; - ok ! defined $x->autoflush(1) ; - ok ! defined $x->fileno() ; - 1 while $x->read($uncomp) > 0 ; - - ok $x->close, "closed" ; - } - - is $uncomp, $hello, "got expected uncompressed data" ; - ok $buffer eq $keep, "compressed input not changed" ; - } - - if ($CompressClass ne 'RawDeflate') - { - # write empty file - #======================================== - - my $buffer = ''; - { - my $x ; - $x = new $CompressClass(\$buffer); - ok $x, "new $CompressClass" ; - ok $x->close, "close ok" ; - - } - - my $keep = $buffer ; - my $uncomp= ''; - { - my $x ; - ok $x = new $UncompressClass(\$buffer, Append => 1) ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close ; - } - - ok $uncomp eq '' ; - ok $buffer eq $keep ; - - } - - { - # write a larger file - #======================================== - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - my $input = '' ; - my $contents = '' ; - - { - my $x = new $CompressClass $name ; - ok $x, " created $CompressClass object"; - - ok $x->write($hello), " write ok" ; - $input .= $hello ; - ok $x->write("another line"), " write ok" ; - $input .= "another line" ; - # all characters - foreach (0 .. 255) - { $contents .= chr int $_ } - # generate a long random string - foreach (1 .. 5000) - { $contents .= chr int rand 256 } - - ok $x->write($contents), " write ok" ; - $input .= $contents ; - ok $x->close, " close ok" ; - } - - ok myGZreadFile($name) eq $input ; - my $x = readFile($name) ; - #print "length " . length($x) . " \n"; - } - - { - # embed a compressed file in another file - #================================ - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - my $header = "header info\n" ; - my $trailer = "trailer data\n" ; - - { - my $fh ; - ok $fh = new IO::File ">$name" ; - print $fh $header ; - my $x ; - ok $x = new $CompressClass $fh, - -AutoClose => 0 ; - - ok $x->binmode(); - ok $x->write($hello) ; - ok $x->close ; - print $fh $trailer ; - $fh->close() ; - } - - my ($fil, $uncomp) ; - my $fh1 ; - ok $fh1 = new IO::File "<$name" ; - # skip leading junk - my $line = <$fh1> ; - ok $line eq $header ; - - ok my $x = new $UncompressClass $fh1, Append => 1 ; - ok $x->binmode(); - 1 while $x->read($uncomp) > 0 ; - - ok $uncomp eq $hello ; - my $rest ; - read($fh1, $rest, 5000); - is $x->trailingData() . $rest, $trailer ; - #print "# [".$x->trailingData() . "][$rest]\n" ; - - } - - { - # embed a compressed file in another buffer - #================================ - - - my $hello = <<EOM ; -hello world -this is a test -EOM - - my $trailer = "trailer data" ; - - my $compressed ; - - { - ok my $x = new $CompressClass(\$compressed); - - ok $x->write($hello) ; - ok $x->close ; - $compressed .= $trailer ; - } - - my $uncomp; - ok my $x = new $UncompressClass(\$compressed, Append => 1) ; - 1 while $x->read($uncomp) > 0 ; - - ok $uncomp eq $hello ; - is $x->trailingData(), $trailer ; - - } - - { - # Write - # these tests come almost 100% from IO::String - - my $lex = new LexFile my $name ; - - my $io = $CompressClass->new($name); - - is $io->tell(), 0, " tell returns 0"; ; - - my $heisan = "Heisan\n"; - $io->print($heisan) ; - - ok ! $io->eof(), " ! eof"; - - is $io->tell(), length($heisan), " tell is " . length($heisan) ; - - $io->print("a", "b", "c"); - - { - local($\) = "\n"; - $io->print("d", "e"); - local($,) = ","; - $io->print("f", "g", "h"); - } - - { - local($\) ; - $io->print("D", "E"); - local($,) = "."; - $io->print("F", "G", "H"); - } - - my $foo = "1234567890"; - - is $io->syswrite($foo, length($foo)), length($foo), " syswrite ok" ; - if ( $] < 5.6 ) - { is $io->syswrite($foo, length $foo), length $foo, " syswrite ok" } - else - { is $io->syswrite($foo), length $foo, " syswrite ok" } - is $io->syswrite($foo, length($foo)), length $foo, " syswrite ok"; - is $io->write($foo, length($foo), 5), 5, " write 5"; - is $io->write("xxx\n", 100, -1), 1, " write 1"; - - for (1..3) { - $io->printf("i(%d)", $_); - $io->printf("[%d]\n", $_); - } - $io->print("\n"); - - $io->close ; - - ok $io->eof(), " eof"; - - is myGZreadFile($name), "Heisan\nabcde\nf,g,h\nDEF.G.H" . - ("1234567890" x 3) . "67890\n" . - "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n", - "myGZreadFile ok"; - - - } - - { - # Read - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - my %opts = () ; - my $iow = new $CompressClass $name, %opts; - is $iow->input_line_number, undef; - $iow->print($str) ; - is $iow->input_line_number, undef; - $iow->close ; - - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name ; - - is $., 0; - is $io->input_line_number, 0; - ok ! $io->eof, "eof"; - is $io->tell(), 0, "tell 0" ; - #my @lines = <$io>; - my @lines = $io->getlines(); - is @lines, 6 - or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; - is $lines[1], "of a paragraph\n" ; - is join('', @lines), $str ; - is $., 6; - is $io->input_line_number, 6; - is $io->tell(), length($str) ; - - ok $io->eof; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined($io->getline) || - defined($io->getc) || - $io->read($buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - is $., 0; - is $io->input_line_number, 0; - ok ! $io->eof; - my @lines = $io->getlines; - is $., 1; - is $io->input_line_number, 1; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = $io->getline(); - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - is $., 0; - is $io->input_line_number, 0; - ok ! $io->eof; - my @lines = $io->getlines(); - is $., 2; - is $io->input_line_number, 2; - ok $io->eof; - ok @lines == 2 - or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# $lines[0]\n"; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - # Record mode - my $reclen = 7 ; - my $expected_records = int(length($str) / $reclen) - + (length($str) % $reclen ? 1 : 0); - local $/ = \$reclen; - - my $io = $UncompressClass->new($name); - is $., 0; - is $io->input_line_number, 0; - - ok ! $io->eof; - my @lines = $io->getlines(); - is $., $expected_records; - is $io->input_line_number, $expected_records; - ok $io->eof; - is @lines, $expected_records, - "Got $expected_records records\n" ; - ok $lines[0] eq substr($str, 0, $reclen) - or print "# $lines[0]\n"; - ok $lines[1] eq substr($str, $reclen, $reclen); - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (my $a = $io->getline()) { - push(@lines, $a); - $err++ if $. != ++$no; - } - - ok $err == 0 ; - ok $io->eof; - - is $., 3; - is $io->input_line_number, 3; - ok @lines == 3 - or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test read - - { - my $io = $UncompressClass->new($name); - - - eval { $io->read(1) } ; - like $@, mkErr("buffer parameter is read-only"); - - $buf = "abcd"; - is $io->read($buf, 0), 0, "Requested 0 bytes" ; - is $buf, "", "Buffer empty"; - - is $io->read($buf, 3), 3 ; - is $buf, "Thi"; - - is $io->sysread($buf, 3, 2), 3 ; - is $buf, "Ths i" - or print "# [$buf]\n" ;; - ok ! $io->eof; - - $buf = "ab" ; - is $io->read($buf, 3, 4), 3 ; - is $buf, "ab" . "\x00" x 2 . "s a" - or print "# [$buf]\n" ;; - ok ! $io->eof; - - # read the rest of the file - $buf = ''; - my $remain = length($str) - 9; - is $io->read($buf, $remain+1), $remain ; - is $buf, substr($str, 9); - ok $io->eof; - - $buf = "hello"; - is $io->read($buf, 10), 0 ; - is $buf, "", "Buffer empty"; - ok $io->eof; - - ok $io->close(); - $buf = "hello"; - is $io->read($buf, 10), 0 ; - is $buf, "hello", "Buffer not empty"; - ok $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - } - - { - # Read from non-compressed file - - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - writeFile($name, $str); - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name, -Transparent => 1 ; - - ok defined $io; - ok ! $io->eof; - ok $io->tell() == 0 ; - my @lines = $io->getlines(); - is @lines, 6; - ok $lines[1] eq "of a paragraph\n" ; - ok join('', @lines) eq $str ; - is $., 6; - is $io->input_line_number, 6; - ok $io->tell() == length($str) ; - - ok $io->eof; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined($io->getline) || - defined($io->getc) || - $io->read($buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines; - is $., 1; - is $io->input_line_number, 1; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = $io->getline; - is $., 1; - is $io->input_line_number, 1; - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines; - is $., 2; - is $io->input_line_number, 2; - ok $io->eof; - ok @lines == 2 - or print "# exected 2 lines, got " . scalar(@lines) . "\n"; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# [$lines[0]]\n" ; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - # Record mode - my $reclen = 7 ; - my $expected_records = int(length($str) / $reclen) - + (length($str) % $reclen ? 1 : 0); - local $/ = \$reclen; - - my $io = $UncompressClass->new($name); - is $., 0; - is $io->input_line_number, 0; - - ok ! $io->eof; - my @lines = $io->getlines(); - is $., $expected_records; - is $io->input_line_number, $expected_records; - ok $io->eof; - is @lines, $expected_records, - "Got $expected_records records\n" ; - ok $lines[0] eq substr($str, 0, $reclen) - or print "# $lines[0]\n"; - ok $lines[1] eq substr($str, $reclen, $reclen); - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (my $a = $io->getline) { - push(@lines, $a); - $err++ if $. != ++$no; - } - - is $., 3; - is $io->input_line_number, 3; - ok $err == 0 ; - ok $io->eof; - - - ok @lines == 3 ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test Read - - { - my $io = $UncompressClass->new($name); - - $buf = "abcd"; - is $io->read($buf, 0), 0, "Requested 0 bytes" ; - is $buf, "", "Buffer empty"; - - ok $io->read($buf, 3) == 3 ; - ok $buf eq "Thi"; - - ok $io->sysread($buf, 3, 2) == 3 ; - ok $buf eq "Ths i"; - ok ! $io->eof; - - $buf = "ab" ; - is $io->read($buf, 3, 4), 3 ; - is $buf, "ab" . "\x00" x 2 . "s a" - or print "# [$buf]\n" ;; - ok ! $io->eof; - - # read the rest of the file - $buf = ''; - my $remain = length($str) - 9; - is $io->read($buf, $remain), $remain ; - is $buf, substr($str, 9); - ok $io->eof; - - $buf = "hello"; - is $io->read($buf, 10), 0 ; - is $buf, "", "Buffer empty"; - ok $io->eof; - - ok $io->close(); - $buf = "hello"; - is $io->read($buf, 10), 0 ; - is $buf, "hello", "Buffer not empty"; - ok $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - - } - - { - # Vary the length parameter in a read - - my $str = <<EOT; -x -x -This is an example -of a paragraph - - -and a single line. - -EOT - $str = $str x 100 ; - - - foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) - { - foreach my $trans (0, 1) - { - foreach my $append (0, 1) - { - title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; - - my $lex = new LexFile my $name ; - - if ($trans) { - writeFile($name, $str) ; - } - else { - my $iow = new $CompressClass $name; - $iow->print($str) ; - $iow->close ; - } - - - my $io = $UncompressClass->new($name, - -Append => $append, - -Transparent => $trans); - - my $buf; - - is $io->tell(), 0; - - if ($append) { - 1 while $io->read($buf, $bufsize) > 0; - } - else { - my $tmp ; - $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; - } - is length $buf, length $str; - ok $buf eq $str ; - ok ! $io->error() ; - ok $io->eof; - } - } - } - } - - foreach my $file (0, 1) - { - foreach my $trans (0, 1) - { - title "seek tests - file $file trans $trans" ; - - my $buffer ; - my $buff ; - my $lex = new LexFile my $name ; - - my $first = "beginning" ; - my $last = "the end" ; - - if ($trans) - { - $buffer = $first . "\x00" x 10 . $last; - writeFile($name, $buffer); - } - else - { - my $output ; - if ($file) - { - $output = $name ; - } - else - { - $output = \$buffer; - } - - my $iow = new $CompressClass $output ; - $iow->print($first) ; - ok $iow->seek(5, SEEK_CUR) ; - ok $iow->tell() == length($first)+5; - ok $iow->seek(0, SEEK_CUR) ; - ok $iow->tell() == length($first)+5; - ok $iow->seek(length($first)+10, SEEK_SET) ; - ok $iow->tell() == length($first)+10; - - $iow->print($last) ; - $iow->close ; - } - - my $input ; - if ($file) - { - $input = $name ; - } - else - { - $input = \$buffer ; - } - - ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ; - - my $io = $UncompressClass->new($input, Strict => 1); - ok $io->seek(length($first), SEEK_CUR) - or diag $$UnError ; - ok ! $io->eof; - is $io->tell(), length($first); - - ok $io->read($buff, 5) ; - is $buff, "\x00" x 5 ; - is $io->tell(), length($first) + 5; - - ok $io->seek(0, SEEK_CUR) ; - my $here = $io->tell() ; - is $here, length($first)+5; - - ok $io->seek($here+5, SEEK_SET) ; - is $io->tell(), $here+5 ; - ok $io->read($buff, 100) ; - ok $buff eq $last ; - ok $io->eof; - } - } - - { - title "seek error cases" ; - - my $b ; - my $a = new $CompressClass(\$b) ; - - ok ! $a->error() ; - eval { $a->seek(-1, 10) ; }; - like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter"); - - eval { $a->seek(-1, SEEK_END) ; }; - like $@, mkErr("^${CompressClass}::seek: cannot seek backwards"); - - $a->write("fred"); - $a->close ; - - - my $u = new $UncompressClass(\$b) ; - - eval { $u->seek(-1, 10) ; }; - like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter"); - - eval { $u->seek(-1, SEEK_END) ; }; - like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed"); - - eval { $u->seek(-1, SEEK_CUR) ; }; - like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards"); - } - - foreach my $fb (qw(filename buffer filehandle)) - { - foreach my $append (0, 1) - { - { - title "$CompressClass -- Append $append, Output to $fb" ; - - my $lex = new LexFile my $name ; - - my $already = 'already'; - my $buffer = $already; - my $output; - - if ($fb eq 'buffer') - { $output = \$buffer } - elsif ($fb eq 'filename') - { - $output = $name ; - writeFile($name, $buffer); - } - elsif ($fb eq 'filehandle') - { - $output = new IO::File ">$name" ; - print $output $buffer; - } - - my $a = new $CompressClass($output, Append => $append) ; - ok $a, " Created $CompressClass"; - my $string = "appended"; - $a->write($string); - $a->close ; - - my $data ; - if ($fb eq 'buffer') - { - $data = $buffer; - } - else - { - $output->close - if $fb eq 'filehandle'; - $data = readFile($name); - } - - if ($append || $fb eq 'filehandle') - { - is substr($data, 0, length($already)), $already, " got prefix"; - substr($data, 0, length($already)) = ''; - } - - - my $uncomp; - my $x = new $UncompressClass(\$data, Append => 1) ; - ok $x, " created $UncompressClass"; - - my $len ; - 1 while ($len = $x->read($uncomp)) > 0 ; - - $x->close ; - is $uncomp, $string, ' Got uncompressed data' ; - - } - } - } - - foreach my $type (qw(buffer filename filehandle)) - { - foreach my $good (0, 1) - { - title "$UncompressClass -- InputLength, read from $type, good data => $good"; - - my $compressed ; - my $string = "some data"; - my $appended = "append"; - - if ($good) - { - my $c = new $CompressClass(\$compressed); - $c->write($string); - $c->close(); - } - else - { - $compressed = $string ; - } - - my $comp_len = length $compressed; - $compressed .= $appended; - - my $lex = new LexFile my $name ; - my $input ; - writeFile ($name, $compressed); - - if ($type eq 'buffer') - { - $input = \$compressed; - } - if ($type eq 'filename') - { - $input = $name; - } - elsif ($type eq 'filehandle') - { - my $fh = new IO::File "<$name" ; - ok $fh, "opened file $name ok"; - $input = $fh ; - } - - my $x = new $UncompressClass($input, - InputLength => $comp_len, - Transparent => 1) ; - ok $x, " created $UncompressClass"; - - my $len ; - my $output; - $len = $x->read($output, 100); - - is $len, length($string); - is $output, $string; - - if ($type eq 'filehandle') - { - my $rest ; - $input->read($rest, 1000); - is $rest, $appended; - } - } - - - } - - foreach my $append (0, 1) - { - title "$UncompressClass -- Append $append" ; - - my $lex = new LexFile my $name ; - - my $string = "appended"; - my $compressed ; - my $c = new $CompressClass(\$compressed); - $c->write($string); - $c->close(); - - my $x = new $UncompressClass(\$compressed, Append => $append) ; - ok $x, " created $UncompressClass"; - - my $already = 'already'; - my $output = $already; - - my $len ; - $len = $x->read($output, 100); - is $len, length($string); - - $x->close ; - - if ($append) - { - is substr($output, 0, length($already)), $already, " got prefix"; - substr($output, 0, length($already)) = ''; - } - is $output, $string, ' Got uncompressed data' ; - } - - - foreach my $file (0, 1) - { - foreach my $trans (0, 1) - { - title "ungetc, File $file, Transparent $trans" ; - - my $lex = new LexFile my $name ; - - my $string = 'abcdeABCDE'; - my $b ; - if ($trans) - { - $b = $string ; - } - else - { - my $a = new $CompressClass(\$b) ; - $a->write($string); - $a->close ; - } - - my $from ; - if ($file) - { - writeFile($name, $b); - $from = $name ; - } - else - { - $from = \$b ; - } - - my $u = $UncompressClass->new($from, Transparent => 1) ; - my $first; - my $buff ; - - # do an ungetc before reading - $u->ungetc("X"); - $first = $u->getc(); - is $first, 'X'; - - $first = $u->getc(); - is $first, substr($string, 0,1); - $u->ungetc($first); - $first = $u->getc(); - is $first, substr($string, 0,1); - $u->ungetc($first); - - is $u->read($buff, 5), 5 ; - is $buff, substr($string, 0, 5); - - $u->ungetc($buff) ; - is $u->read($buff, length($string)), length($string) ; - is $buff, $string; - - is $u->read($buff, 1), 0; - ok $u->eof() ; - - my $extra = 'extra'; - $u->ungetc($extra); - ok ! $u->eof(); - is $u->read($buff), length($extra) ; - is $buff, $extra; - - is $u->read($buff, 1), 0; - ok $u->eof() ; - - # getc returns undef on eof - is $u->getc(), undef; - $u->close(); - - } - } - - { - title "write tests - invalid data" ; - - #my $lex = new LexFile my $name1 ; - my($Answer); - - #ok ! -e $name1, " File $name1 does not exist"; - - my @data = ( - [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], - [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], - [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], - [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ], - [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ], - [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ], - #[ "not readable", 'xx' ], - # same filehandle twice, 'xx' - ) ; - - foreach my $data (@data) - { - my ($send, $get) = @$data ; - title "${CompressClass}::write( $send )"; - my($copy); - eval "\$copy = $send"; - my $x = new $CompressClass(\$Answer); - ok $x, " Created $CompressClass object"; - eval { $x->write($copy) } ; - #like $@, "/^$get/", " error - $get"; - like $@, "/not a scalar reference /", " error - not a scalar reference"; - } - - # @data = ( - # [ '[ $name1 ]', "input file '$name1' does not exist" ], - # #[ "not readable", 'xx' ], - # # same filehandle twice, 'xx' - # ) ; - # - # foreach my $data (@data) - # { - # my ($send, $get) = @$data ; - # title "${CompressClass}::write( $send )"; - # my $copy; - # eval "\$copy = $send"; - # my $x = new $CompressClass(\$Answer); - # ok $x, " Created $CompressClass object"; - # ok ! $x->write($copy), " write fails" ; - # like $$Error, "/^$get/", " error - $get"; - # } - - #exit; - - } - - - # sub deepCopy - # { - # if (! ref $_[0] || ref $_[0] eq 'SCALAR') - # { - # return $_[0] ; - # } - # - # if (ref $_[0] eq 'ARRAY') - # { - # my @a ; - # for my $x ( @{ $_[0] }) - # { - # push @a, deepCopy($x); - # } - # - # return \@a ; - # } - # - # croak "bad! $_[0]"; - # - # } - # - # sub deepSubst - # { - # #my $data = shift ; - # my $from = $_[1] ; - # my $to = $_[2] ; - # - # if (! ref $_[0]) - # { - # $_[0] = $to - # if $_[0] eq $from ; - # return ; - # - # } - # - # if (ref $_[0] eq 'SCALAR') - # { - # $_[0] = \$to - # if defined ${ $_[0] } && ${ $_[0] } eq $from ; - # return ; - # - # } - # - # if (ref $_[0] eq 'ARRAY') - # { - # for my $x ( @{ $_[0] }) - # { - # deepSubst($x, $from, $to); - # } - # return ; - # } - # #croak "bad! $_[0]"; - # } - - # { - # title "More write tests" ; - # - # my $file1 = "file1" ; - # my $file2 = "file2" ; - # my $file3 = "file3" ; - # my $lex = new LexFile $file1, $file2, $file3 ; - # - # writeFile($file1, "F1"); - # writeFile($file2, "F2"); - # writeFile($file3, "F3"); - # - # my @data = ( - # [ '""', "" ], - # [ 'undef', "" ], - # [ '"abcd"', "abcd" ], - # - # [ '\""', "" ], - # [ '\undef', "" ], - # [ '\"abcd"', "abcd" ], - # - # [ '[]', "" ], - # [ '[[]]', "" ], - # [ '[[[]]]', "" ], - # [ '[\""]', "" ], - # [ '[\undef]', "" ], - # [ '[\"abcd"]', "abcd" ], - # [ '[\"ab", \"cd"]', "abcd" ], - # [ '[[\"ab"], [\"cd"]]', "abcd" ], - # - # [ '$file1', $file1 ], - # [ '$fh2', "F2" ], - # [ '[$file1, \"abc"]', "F1abc"], - # [ '[\"a", $file1, \"bc"]', "aF1bc"], - # [ '[\"a", $fh1, \"bc"]', "aF1bc"], - # [ '[\"a", $fh1, \"bc", $file2]', "aF1bcF2"], - # [ '[\"a", $fh1, \"bc", $file2, $fh3]', "aF1bcF2F3"], - # ) ; - # - # - # foreach my $data (@data) - # { - # my ($send, $get) = @$data ; - # - # my $fh1 = new IO::File "< $file1" ; - # my $fh2 = new IO::File "< $file2" ; - # my $fh3 = new IO::File "< $file3" ; - # - # title "${CompressClass}::write( $send )"; - # my $copy; - # eval "\$copy = $send"; - # my $Answer ; - # my $x = new $CompressClass(\$Answer); - # ok $x, " Created $CompressClass object"; - # my $len = length $get; - # is $x->write($copy), length($get), " write $len bytes"; - # ok $x->close(), " close ok" ; - # - # is myGZreadFile(\$Answer), $get, " got expected output" ; - # cmp_ok $$Error, '==', 0, " no error"; - # - # - # } - # - # } - } - -} - -1; - - - - - diff --git a/ext/IO-Compress/t/compress/merge.pl b/ext/IO-Compress/t/compress/merge.pl deleted file mode 100644 index 6134292466..0000000000 --- a/ext/IO-Compress/t/compress/merge.pl +++ /dev/null @@ -1,322 +0,0 @@ -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use CompTestUtils; - -use Compress::Raw::Zlib 2 ; - -BEGIN -{ - plan(skip_all => "Merge needs Zlib 1.2.1 or better - you have Zlib " - . Compress::Raw::Zlib::zlib_version()) - if ZLIB_VERNUM() < 0x1210 ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 165 + $extra ; - -} - - -sub run -{ - - my $CompressClass = identify(); - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - # Tests - # destination is a file that doesn't exist -- should work ok unless AnyDeflate - # destination isn't compressed at all - # destination is compressed but wrong format - # destination is corrupt - error messages should be correct - # use apend mode with old zlib - check that this is trapped - # destination is not seekable, readable, writable - test for filename & handle - - { - title "Misc error cases"; - - eval { new Compress::Raw::Zlib::InflateScan Bufsize => 0} ; - like $@, mkErr("^Compress::Raw::Zlib::InflateScan::new: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0"; - - eval { Compress::Raw::Zlib::inflateScanStream::createDeflateStream(undef, Bufsize => 0) } ; - like $@, mkErr("^Compress::Raw::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0"; - - } - - # output file/handle not writable - { - - foreach my $to_file (0,1) - { - if ($to_file) - { title "$CompressClass - Merge to filename that isn't writable" } - else - { title "$CompressClass - Merge to filehandle that isn't writable" } - - my $lex = new LexFile my $out_file ; - - # create empty file - open F, ">$out_file" ; print F "x"; close F; - ok -e $out_file, " file exists" ; - ok !-z $out_file, " and is not empty" ; - - # make unwritable - is chmod(0444, $out_file), 1, " chmod worked" ; - ok -e $out_file, " still exists after chmod" ; - - SKIP: - { - skip "Cannot create non-writable file", 3 - if -w $out_file ; - - ok ! -w $out_file, " chmod made file unwritable" ; - - my $dest ; - if ($to_file) - { $dest = $out_file } - else - { $dest = new IO::File "<$out_file" } - - my $gz = $CompressClass->new($dest, Merge => 1) ; - - ok ! $gz, " Did not create $CompressClass object"; - - ok $$Error, " Got error message" ; - } - - chmod 0777, $out_file ; - } - } - - # output is not compressed at all - { - - my $lex = new LexFile my $out_file ; - - foreach my $to_file ( qw(buffer file handle ) ) - { - title "$CompressClass to $to_file, content is not compressed"; - - my $content = "abc" x 300 ; - my $buffer ; - my $disp_content = defined $content ? $content : '<undef>' ; - my $str_content = defined $content ? $content : '' ; - - if ($to_file eq 'buffer') - { - $buffer = \$content ; - } - else - { - writeFile($out_file, $content); - - if ($to_file eq 'handle') - { - $buffer = new IO::File "+<$out_file" - or die "# Cannot open $out_file: $!"; - } - else - { $buffer = $out_file } - } - - ok ! $CompressClass->new($buffer, Merge => 1), " constructor fails"; - { - like $$Error, '/Cannot create InflateScan object: (Header Error|unexpected end of file|Inflation Error: data error)/', " got Bad Magic" ; - } - - } - } - - # output is empty - { - - my $lex = new LexFile my $out_file ; - - foreach my $to_file ( qw(buffer file handle ) ) - { - title "$CompressClass to $to_file, content is empty"; - - my $content = ''; - my $buffer ; - my $dest ; - - if ($to_file eq 'buffer') - { - $dest = $buffer = \$content ; - } - else - { - writeFile($out_file, $content); - $dest = $out_file; - - if ($to_file eq 'handle') - { - $buffer = new IO::File "+<$out_file" - or die "# Cannot open $out_file: $!"; - } - else - { $buffer = $out_file } - } - - ok my $gz = $CompressClass->new($buffer, Merge => 1, AutoClose => 1), " constructor passes" - or diag $$Error; - - $gz->write("FGHI"); - $gz->close(); - - #hexDump($buffer); - my $out = anyUncompress($dest); - - is $out, "FGHI", ' Merge OK'; - } - } - - { - title "$CompressClass - Merge to file that doesn't exist"; - - my $lex = new LexFile my $out_file ; - - ok ! -e $out_file, " Destination file, '$out_file', does not exist"; - - ok my $gz1 = $CompressClass->new($out_file, Merge => 1) - or die "# $CompressClass->new failed: $$Error\n"; - #hexDump($buffer); - $gz1->write("FGHI"); - $gz1->close(); - - #hexDump($buffer); - my $out = anyUncompress($out_file); - - is $out, "FGHI", ' Merged OK'; - } - - { - - my $lex = new LexFile my $out_file ; - - foreach my $to_file ( qw( buffer file handle ) ) - { - foreach my $content (undef, '', 'x', 'abcde') - { - #next if ! defined $content && $to_file; - - my $buffer ; - my $disp_content = defined $content ? $content : '<undef>' ; - my $str_content = defined $content ? $content : '' ; - - if ($to_file eq 'buffer') - { - my $x ; - $buffer = \$x ; - title "$CompressClass to Buffer, content is '$disp_content'"; - } - else - { - $buffer = $out_file ; - if ($to_file eq 'handle') - { - title "$CompressClass to Filehandle, content is '$disp_content'"; - } - else - { - title "$CompressClass to File, content is '$disp_content'"; - } - } - - my $gz = $CompressClass->new($buffer); - my $len = defined $content ? length($content) : 0 ; - is $gz->write($content), $len, " write ok"; - ok $gz->close(), " close ok"; - - #hexDump($buffer); - is anyUncompress($buffer), $str_content, ' Destination is ok'; - - #if ($corruption) - #{ - # next if $TopTypes eq 'RawDeflate' && $content eq ''; - # - #} - - my $dest = $buffer ; - if ($to_file eq 'handle') - { - $dest = new IO::File "+<$buffer" ; - } - - my $gz1 = $CompressClass->new($dest, Merge => 1, AutoClose => 1) - or die "## Error is $$Error\n"; - - #print "YYY\n"; - #hexDump($buffer); - #print "XXX\n"; - is $gz1->write("FGHI"), 4, " write returned 4"; - ok $gz1->close(), " close ok"; - - #hexDump($buffer); - my $out = anyUncompress($buffer); - - is $out, $str_content . "FGHI", ' Merged OK'; - #exit; - } - } - - } - - - - { - my $Func = getTopFuncRef($CompressClass); - my $TopType = getTopFuncName($CompressClass); - - my $buffer ; - - my $lex = new LexFile my $out_file ; - - foreach my $to_file (0, 1) - { - foreach my $content (undef, '', 'x', 'abcde') - { - my $disp_content = defined $content ? $content : '<undef>' ; - my $str_content = defined $content ? $content : '' ; - my $buffer ; - if ($to_file) - { - $buffer = $out_file ; - title "$TopType to File, content is '$disp_content'"; - } - else - { - my $x = ''; - $buffer = \$x ; - title "$TopType to Buffer, content is '$disp_content'"; - } - - - ok $Func->(\$content, $buffer), " Compress content"; - #hexDump($buffer); - is anyUncompress($buffer), $str_content, ' Destination is ok'; - - - ok $Func->(\"FGHI", $buffer, Merge => 1), " Merge content"; - - #hexDump($buffer); - my $out = anyUncompress($buffer); - - is $out, $str_content . "FGHI", ' Merged OK'; - } - } - - } - -} - - -1; diff --git a/ext/IO-Compress/t/compress/multi.pl b/ext/IO-Compress/t/compress/multi.pl deleted file mode 100644 index 3e9bbfd464..0000000000 --- a/ext/IO-Compress/t/compress/multi.pl +++ /dev/null @@ -1,261 +0,0 @@ - -use lib 't'; -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 => 1324 + $extra ; - - use_ok('IO::Uncompress::AnyUncompress', qw($AnyUncompressError)) ; - -} - -sub run -{ - - my $CompressClass = identify(); - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - - - - my @buffers ; - push @buffers, <<EOM ; -hello world -this is a test -some more stuff on this line -ad finally... -EOM - - push @buffers, <<EOM ; -some more stuff -line 2 -EOM - - push @buffers, <<EOM ; -even more stuff -EOM - - my $b0length = length $buffers[0]; - my $bufcount = @buffers; - - { - my $cc ; - my $gz ; - my $hsize ; - my %headers = () ; - - - foreach my $fb ( qw( file filehandle buffer ) ) - { - - foreach my $i (1 .. @buffers) { - - title "Testing $CompressClass with $i streams to $fb"; - - my @buffs = @buffers[0..$i -1] ; - - if ($CompressClass eq 'IO::Compress::Gzip') { - %headers = ( - Strict => 1, - Comment => "this is a comment", - ExtraField => ["so" => "me extra"], - HeaderCRC => 1); - - } - - my $lex = new LexFile my $name ; - my $output ; - if ($fb eq 'buffer') - { - my $compressed = ''; - $output = \$compressed; - } - elsif ($fb eq 'filehandle') - { - $output = new IO::File ">$name" ; - } - else - { - $output = $name ; - } - - my $x = new $CompressClass($output, AutoClose => 1, %headers); - isa_ok $x, $CompressClass, ' $x' ; - - foreach my $buffer (@buffs) { - ok $x->write($buffer), " Write OK" ; - # this will add an extra "empty" stream - ok $x->newStream(), " newStream OK" ; - } - ok $x->close, " Close ok" ; - - #hexDump($compressed) ; - - foreach my $unc ($UncompressClass, 'IO::Uncompress::AnyUncompress') { - title " Testing $CompressClass with $unc and $i streams, from $fb"; - $cc = $output ; - if ($fb eq 'filehandle') - { - $cc = new IO::File "<$name" ; - } - my @opts = $unc ne $UncompressClass - ? (RawInflate => 1) - : (); - my $gz = new $unc($cc, - @opts, - Strict => 1, - AutoClose => 1, - Append => 1, - MultiStream => 1, - Transparent => 0) - or diag $$UnError; - isa_ok $gz, $UncompressClass, ' $gz' ; - - my $un = ''; - 1 while $gz->read($un) > 0 ; - #print "[[$un]]\n" while $gz->read($un) > 0 ; - ok ! $gz->error(), " ! error()" - or diag "Error is " . $gz->error() ; - ok $gz->eof(), " eof()"; - ok $gz->close(), " close() ok" - or diag "errno $!\n" ; - - is $gz->streamCount(), $i +1, " streamCount ok " . ($i +1) - or diag "Stream count is " . $gz->streamCount(); - ok $un eq join('', @buffs), " expected output" ; - - } - - foreach my $unc ($UncompressClass, 'IO::Uncompress::AnyUncompress') { - foreach my $blk (1, 20, $b0length - 1, $b0length, $b0length +1) { - title " Testing $CompressClass with $unc, BlockSize $blk and $i streams, from $fb"; - $cc = $output ; - if ($fb eq 'filehandle') - { - $cc = new IO::File "<$name" ; - } - my @opts = $unc ne $UncompressClass - ? (RawInflate => 1) - : (); - my $gz = new $unc($cc, - @opts, - Strict => 1, - AutoClose => 1, - Append => 1, - MultiStream => 1, - Transparent => 0) - or diag $$UnError; - isa_ok $gz, $UncompressClass, ' $gz' ; - - my $un = ''; - my $b = $blk; - # Want the first read to be in the middle of a stream - # and the second to cross a stream boundary - $b = 1000 while $gz->read($un, $b) > 0 ; - #print "[[$un]]\n" while $gz->read($un) > 0 ; - ok ! $gz->error(), " ! error()" - or diag "Error is " . $gz->error() ; - ok $gz->eof(), " eof()"; - ok $gz->close(), " close() ok" - or diag "errno $!\n" ; - - is $gz->streamCount(), $i +1, " streamCount ok " . ($i +1) - or diag "Stream count is " . $gz->streamCount(); - ok $un eq join('', @buffs), " expected output" ; - - } - } - - foreach my $unc ($UncompressClass, 'IO::Uncompress::AnyUncompress') { - title " Testing $CompressClass with $unc nextStream and $i streams, from $fb"; - $cc = $output ; - if ($fb eq 'filehandle') - { - $cc = new IO::File "<$name" ; - } - my @opts = $unc ne $UncompressClass - ? (RawInflate => 1) - : (); - my $gz = new $unc($cc, - @opts, - Strict => 1, - AutoClose => 1, - Append => 1, - MultiStream => 0, - Transparent => 0) - or diag $$UnError; - isa_ok $gz, $UncompressClass, ' $gz' ; - - for my $stream (1 .. $i) - { - my $buff = $buffs[$stream-1]; - my @lines = split("\n", $buff); - my $lines = @lines; - - my $un = ''; - #while (<$gz>) { - while ($_ = $gz->getline()) { - $un .= $_; - } - is $., $lines, " \$. is $lines"; - - ok ! $gz->error(), " ! error()" - or diag "Error is " . $gz->error() ; - ok $gz->eof(), " eof()"; - is $gz->streamCount(), $stream, " streamCount is $stream" - or diag "Stream count is " . $gz->streamCount(); - ok $un eq $buff, " expected output" ; - #is $gz->tell(), length $buff, " tell is ok"; - is $gz->nextStream(), 1, " nextStream ok"; - is $gz->tell(), 0, " tell is 0"; - is $., 0, ' $. is 0'; - } - - { - my $un = ''; - #1 while $gz->read($un) > 0 ; - is $., 0, " \$. is 0"; - $gz->read($un) ; - #print "[[$un]]\n" while $gz->read($un) > 0 ; - ok ! $gz->error(), " ! error()" - or diag "Error is " . $gz->error() ; - ok $gz->eof(), " eof()"; - is $gz->streamCount(), $i+1, " streamCount is ok" - or diag "Stream count is " . $gz->streamCount(); - ok $un eq "", " expected output" ; - is $gz->tell(), 0, " tell is 0"; - } - - is $gz->nextStream(), 0, " nextStream ok" - or diag $gz->error() ; - ok $gz->eof(), " eof()"; - ok $gz->close(), " close() ok" - or diag "errno $!\n" ; - - is $gz->streamCount(), $i +1, " streamCount ok" - or diag "Stream count is " . $gz->streamCount(); - - } - } - } - } -} - - -# corrupt one of the streams - all previous should be ok -# trailing stuff -# check that "tell" works ok - -1; diff --git a/ext/IO-Compress/t/compress/newtied.pl b/ext/IO-Compress/t/compress/newtied.pl deleted file mode 100644 index 41861e9072..0000000000 --- a/ext/IO-Compress/t/compress/newtied.pl +++ /dev/null @@ -1,374 +0,0 @@ -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use CompTestUtils; - -our ($BadPerl, $UncompressClass); - -BEGIN -{ - plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" ) - if $] < 5.006 ; - - my $tests ; - - $BadPerl = ($] >= 5.006 and $] <= 5.008) ; - - if ($BadPerl) { - $tests = 78 ; - } - else { - $tests = 84 ; - } - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => $tests + $extra ; - -} - - -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - - - -sub myGZreadFile -{ - my $filename = shift ; - my $init = shift ; - - - my $fil = new $UncompressClass $filename, - -Strict => 1, - -Append => 1 - ; - - my $data ; - $data = $init if defined $init ; - 1 while $fil->read($data) > 0; - - $fil->close ; - return $data ; -} - - -sub run -{ - - my $CompressClass = identify(); - $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - { - title "Testing $CompressClass and $UncompressClass"; - - - - { - # Write - # these tests come almost 100% from IO::String - - my $lex = new LexFile my $name ; - - my $io = $CompressClass->new($name); - - is tell($io), 0 ; - is $io->tell(), 0 ; - - my $heisan = "Heisan\n"; - print $io $heisan ; - - ok ! eof($io); - ok ! $io->eof(); - - is tell($io), length($heisan) ; - is $io->tell(), length($heisan) ; - - $io->print("a", "b", "c"); - - { - local($\) = "\n"; - print $io "d", "e"; - local($,) = ","; - print $io "f", "g", "h"; - } - - my $foo = "1234567890"; - - ok syswrite($io, $foo, length($foo)) == length($foo) ; - if ( $] < 5.6 ) - { is $io->syswrite($foo, length $foo), length $foo } - else - { is $io->syswrite($foo), length $foo } - ok $io->syswrite($foo, length($foo)) == length $foo; - ok $io->write($foo, length($foo), 5) == 5; - ok $io->write("xxx\n", 100, -1) == 1; - - for (1..3) { - printf $io "i(%d)", $_; - $io->printf("[%d]\n", $_); - } - select $io; - print "\n"; - select STDOUT; - - close $io ; - - ok eof($io); - ok $io->eof(); - - is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . - ("1234567890" x 3) . "67890\n" . - "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; - - - } - - { - # Read - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - my $iow = new $CompressClass $name ; - print $iow $str ; - close $iow; - - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name ; - - ok ! $io->eof; - ok ! eof $io; - is $io->tell(), 0 ; - is tell($io), 0 ; - my @lines = <$io>; - is @lines, 6 - or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; - is $lines[1], "of a paragraph\n" ; - is join('', @lines), $str ; - is $., 6; - #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ; - is $io->tell(), length($str) ; - is tell($io), length($str) ; - - ok $io->eof; - ok eof $io; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined(<$io>) || - defined($io->getc) || - read($io, $buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = <$io>; - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = <$io>; - ok $io->eof; - ok @lines == 2 - or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# $lines[0]\n"; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (<$io>) { - push(@lines, $_); - $err++ if $. != ++$no; - } - - ok $err == 0 ; - ok $io->eof; - - ok @lines == 3 - or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test read - - { - my $io = $UncompressClass->new($name); - - ok $io, "opened ok" ; - - #eval { read($io, $buf, -1); } ; - #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ; - - #eval { read($io, 1) } ; - #like $@, mkErr("buffer parameter is read-only"); - - is read($io, $buf, 0), 0, "Requested 0 bytes" ; - - ok read($io, $buf, 3) == 3 ; - ok $buf eq "Thi"; - - ok sysread($io, $buf, 3, 2) == 3 ; - ok $buf eq "Ths i" - or print "# [$buf]\n" ;; - ok ! $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - } - - - - { - title "seek tests" ; - - my $lex = new LexFile my $name ; - - my $first = "beginning" ; - my $last = "the end" ; - my $iow = new $CompressClass $name ; - print $iow $first ; - ok seek $iow, 10, SEEK_CUR ; - is tell($iow), length($first)+10; - ok $iow->seek(0, SEEK_CUR) ; - is tell($iow), length($first)+10; - print $iow $last ; - close $iow; - - my $io = $UncompressClass->new($name); - ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ; - - $io = $UncompressClass->new($name); - ok seek $io, length($first)+10, SEEK_CUR ; - ok ! $io->eof; - is tell($io), length($first)+10; - ok seek $io, 0, SEEK_CUR ; - is tell($io), length($first)+10; - my $buff ; - ok read $io, $buff, 100 ; - ok $buff eq $last ; - ok $io->eof; - } - - if (! $BadPerl) - { - # seek error cases - my $b ; - my $a = new $CompressClass(\$b) ; - - ok ! $a->error() ; - eval { seek($a, -1, 10) ; }; - like $@, mkErr("seek: unknown value, 10, for whence parameter"); - - eval { seek($a, -1, SEEK_END) ; }; - like $@, mkErr("cannot seek backwards"); - - print $a "fred"; - close $a ; - - - my $u = new $UncompressClass(\$b) ; - - eval { seek($u, -1, 10) ; }; - like $@, mkErr("seek: unknown value, 10, for whence parameter"); - - eval { seek($u, -1, SEEK_END) ; }; - like $@, mkErr("seek: SEEK_END not allowed"); - - eval { seek($u, -1, SEEK_CUR) ; }; - like $@, mkErr("cannot seek backwards"); - } - - { - title 'fileno' ; - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - my $fh ; - ok $fh = new IO::File ">$name" ; - my $x ; - ok $x = new $CompressClass $fh ; - - ok $x->fileno() == fileno($fh) ; - ok $x->fileno() == fileno($x) ; - ok $x->write($hello) ; - ok $x->close ; - $fh->close() ; - } - - my $uncomp; - { - my $x ; - ok my $fh1 = new IO::File "<$name" ; - ok $x = new $UncompressClass $fh1, -Append => 1 ; - ok $x->fileno() == fileno $fh1 ; - ok $x->fileno() == fileno $x ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close ; - } - - ok $hello eq $uncomp ; - } - } -} - -1; diff --git a/ext/IO-Compress/t/compress/oneshot.pl b/ext/IO-Compress/t/compress/oneshot.pl deleted file mode 100644 index 9c76cefdb5..0000000000 --- a/ext/IO-Compress/t/compress/oneshot.pl +++ /dev/null @@ -1,1592 +0,0 @@ -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use CompTestUtils; - -BEGIN { - plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" ) - if $] < 5.005 ; - - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 986 + $extra ; - - use_ok('IO::Uncompress::AnyUncompress', qw(anyuncompress $AnyUncompressError)) ; - -} - -sub run -{ - - my $CompressClass = identify(); - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - my $TopFuncName = getTopFuncName($CompressClass); - - - my @MultiValues = getMultiValues($CompressClass); - - foreach my $bit ($CompressClass, $UncompressClass, - 'IO::Uncompress::AnyUncompress', - ) - { - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - #my $inverse = getInverse($bit); - #my $InverseFunc = getTopFuncRef($inverse); - - title "Testing $TopType Error Cases"; - - my $a; - my $x ; - - eval { $a = $Func->(\$a => \$x, Fred => 1) ;} ; - like $@, mkErr("^$TopType: unknown key value\\(s\\) Fred"), ' Illegal Parameters'; - - eval { $a = $Func->() ;} ; - like $@, "/^$TopType: expected at least 1 parameters/", ' No Parameters'; - - eval { $a = $Func->(\$x, \1) ;} ; - like $$Error, "/^$TopType: output buffer is read-only/", ' Output is read-only' ; - - my $in ; - eval { $a = $Func->($in, \$x) ;} ; - like $@, mkErr("^$TopType: input filename is undef or null string"), - ' Input filename undef' ; - - $in = ''; - eval { $a = $Func->($in, \$x) ;} ; - like $@, mkErr("^$TopType: input filename is undef or null string"), - ' Input filename empty' ; - - { - my $lex1 = new LexFile my $in ; - writeFile($in, "abc"); - my $out = $in ; - eval { $a = $Func->($in, $out) ;} ; - like $@, mkErr("^$TopType: input and output filename are identical"), - ' Input and Output filename are the same'; - } - - { - my $dir = "tmpdir"; - my $lex = new LexDir $dir ; - mkdir $dir, 0777 ; - - $a = $Func->($dir, \$x) ; - is $a, undef, " $TopType returned undef"; - like $$Error, "/input file '$dir' is a directory/", - ' Input filename is a directory'; - - $a = $Func->(\$x, $dir) ; - is $a, undef, " $TopType returned undef"; - like $$Error, "/output file '$dir' is a directory/", - ' Output filename is a directory'; - } - - eval { $a = $Func->(\$in, \$in) ;} ; - like $@, mkErr("^$TopType: input and output buffer are identical"), - ' Input and Output buffer are the same'; - - SKIP: - { - # Threaded 5.6.x seems to have a problem comparing filehandles. - use Config; - - skip 'Cannot compare filehandles with threaded $]', 2 - if $] >= 5.006 && $] < 5.007 && $Config{useithreads}; - - my $lex = new LexFile my $out_file ; - open OUT, ">$out_file" ; - eval { $a = $Func->(\*OUT, \*OUT) ;} ; - like $@, mkErr("^$TopType: input and output handle are identical"), - ' Input and Output handle are the same'; - - close OUT; - is -s $out_file, 0, " File zero length" ; - } - - { - my %x = () ; - my $object = bless \%x, "someClass" ; - - # Buffer not a scalar reference - #eval { $a = $Func->(\$x, \%x) ;} ; - eval { $a = $Func->(\$x, $object) ;} ; - like $@, mkErr("^$TopType: illegal output parameter"), - ' Bad Output Param'; - - # Buffer not a scalar reference - eval { $a = $Func->(\$x, \%x) ;} ; - like $@, mkErr("^$TopType: illegal output parameter"), - ' Bad Output Param'; - - - eval { $a = $Func->(\%x, \$x) ;} ; - like $@, mkErr("^$TopType: illegal input parameter"), - ' Bad Input Param'; - - #eval { $a = $Func->(\%x, \$x) ;} ; - eval { $a = $Func->($object, \$x) ;} ; - like $@, mkErr("^$TopType: illegal input parameter"), - ' Bad Input Param'; - } - - my $filename = 'abc.def'; - ok ! -e $filename, " input file '$filename' does not exist"; - $a = $Func->($filename, \$x) ; - is $a, undef, " $TopType returned undef"; - like $$Error, "/^input file '$filename' does not exist\$/", " input File '$filename' does not exist"; - - $filename = '/tmp/abd/abc.def'; - ok ! -e $filename, " output File '$filename' does not exist"; - $a = $Func->(\$x, $filename) ; - is $a, undef, " $TopType returned undef"; - like $$Error, ("/^(cannot open file '$filename'|input file '$filename' does not exist):/"), " output File '$filename' does not exist"; - - eval { $a = $Func->(\$x, '<abc>') } ; - like $$Error, "/Need input fileglob for outout fileglob/", - ' Output fileglob with no input fileglob'; - is $a, undef, " $TopType returned undef"; - - $a = $Func->('<abc)>', '<abc>') ; - is $a, undef, " $TopType returned undef"; - like $$Error, "/Unmatched \\) in input fileglob/", - " Unmatched ) in input fileglob"; - } - - foreach my $bit ($UncompressClass, - 'IO::Uncompress::AnyUncompress', - ) - { - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - { - my $in ; - my $out ; - my @x ; - - SKIP: - { - use Config; - - skip 'readonly + threads', 1 - if $Config{useithreads}; - - - eval { $a = $Func->(\$in, \$out, TrailingData => \"abc") ;} ; - like $@, mkErr("^$TopType: Parameter 'TrailingData' not writable"), - ' TrailingData output not writable'; - } - - eval { $a = $Func->(\$in, \$out, TrailingData => \@x) ;} ; - like $@, mkErr("^$TopType: Parameter 'TrailingData' not a scalar reference"), - ' TrailingData output not scalar reference'; - } - } - - foreach my $bit ($UncompressClass, - 'IO::Uncompress::AnyUncompress', - ) - { - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $data = "mary had a little lamb" ; - my $keep = $data ; - - for my $trans ( 0, 1) - { - title "Non-compressed data with $TopType, Transparent => $trans "; - my $a; - my $x ; - my $out = '' ; - - $a = $Func->(\$data, \$out, Transparent => $trans) ; - - is $data, $keep, " Input buffer not changed" ; - - if ($trans) - { - ok $a, " $TopType returned true" ; - is $out, $data, " got expected output" ; - ok ! $$Error, " no error [$$Error]" ; - } - else - { - ok ! $a, " $TopType returned false" ; - #like $$Error, '/xxx/', " error" ; - ok $$Error, " error is '$$Error'" ; - } - } - } - - foreach my $bit ($CompressClass - ) - { - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - my $TopTypeInverse = getInverse($bit); - my $FuncInverse = getTopFuncRef($TopTypeInverse); - my $ErrorInverse = getErrorRef($TopTypeInverse); - - title "$TopTypeInverse - corrupt data"; - - my $data = "abcd" x 100 ; - my $out; - - ok $Func->(\$data, \$out), " $TopType ok"; - - # corrupt the compressed data - #substr($out, -10, 10) = "x" x 10 ; - substr($out, int(length($out)/3), 10) = 'abcdeabcde'; - - my $result; - ok ! $FuncInverse->(\$out => \$result, Transparent => 0), " $TopTypeInverse ok"; - ok $$ErrorInverse, " Got error '$$ErrorInverse'" ; - - #is $result, $data, " data ok"; - - ok ! anyuncompress(\$out => \$result, Transparent => 0), "anyuncompress ok"; - ok $AnyUncompressError, " Got error '$AnyUncompressError'" ; - } - - - foreach my $bit ($CompressClass - ) - { - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - my $TopTypeInverse = getInverse($bit); - my $FuncInverse = getTopFuncRef($TopTypeInverse); - - my @opts = (); - @opts = (RawInflate => 1) - if $CompressClass eq 'IO::Compress::RawInflate'; - - for my $append ( 1, 0 ) - { - my $already = ''; - $already = 'abcde' if $append ; - - for my $buffer ( undef, '', "abcde" ) - { - - my $disp_content = defined $buffer ? $buffer : '<undef>' ; - - my $keep = $buffer; - my $out_file = "abcde.out"; - my $in_file = "abcde.in"; - - { - title "$TopType - From Buff to Buff content '$disp_content' Append $append" ; - - my $output = $already; - ok &$Func(\$buffer, \$output, Append => $append), ' Compressed ok' ; - - is $keep, $buffer, " Input buffer not changed" ; - my $got = anyUncompress(\$output, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - - } - - { - title "$TopType - From Buff to Array Ref content '$disp_content' Append $append" ; - - my @output = ('first') ; - ok &$Func(\$buffer, \@output, Append => $append), ' Compressed ok' ; - - is $output[0], 'first', " Array[0] unchanged"; - is $keep, $buffer, " Input buffer not changed" ; - my $got = anyUncompress($output[1]); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - } - - { - title "$TopType - From Array Ref to Array Ref content '$disp_content' Append $append" ; - - my $lex = new LexFile my $in_file ; - writeFile($in_file, $buffer); - my @output = ('first') ; - my @input = ($in_file); - ok &$Func(\@input, \@output, Append => $append), ' Compressed ok' ; - - is $output[0], 'first', " Array[0] unchanged"; - my $got = anyUncompress($output[1]); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - } - - { - title "$TopType - From Buff to Filename content '$disp_content' Append $append" ; - - my $lex = new LexFile my $out_file ; - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - - ok &$Func(\$buffer, $out_file, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - } - - { - title "$TopType - From Buff to Handle content '$disp_content' Append $append" ; - - my $lex = new LexFile my $out_file ; - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - my $of = new IO::File ">>$out_file" ; - ok $of, " Created output filehandle" ; - - ok &$Func(\$buffer, $of, AutoClose => 1, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - } - - - { - title "$TopType - From Filename to Filename content '$disp_content' Append $append" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - writeFile($in_file, $buffer); - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - - ok &$Func($in_file => $out_file, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - - } - - { - title "$TopType - From Filename to Handle content '$disp_content' Append $append" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - writeFile($in_file, $buffer); - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - my $out = new IO::File ">>$out_file" ; - - ok &$Func($in_file, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - - } - - { - title "$TopType - From Filename to Buffer content '$disp_content' Append $append" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - writeFile($in_file, $buffer); - - my $out = $already; - - ok &$Func($in_file => \$out, Append => $append), ' Compressed ok' ; - - my $got = anyUncompress(\$out, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $got, $buffer, " Uncompressed matches original"; - - } - - { - title "$TopType - From Handle to Filename content '$disp_content' Append $append" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - writeFile($in_file, $buffer); - my $in = new IO::File "<$in_file" ; - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - - ok &$Func($in, $out_file, Append => $append), ' Compressed ok' - or diag "error is $$Error" ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $buffer, $got, " Uncompressed matches original"; - - } - - { - title "$TopType - From Handle to Handle content '$disp_content' Append $append" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - writeFile($in_file, $buffer); - my $in = new IO::File "<$in_file" ; - - ok ! -e $out_file, " Output file does not exist"; - writeFile($out_file, $already); - my $out = new IO::File ">>$out_file" ; - - ok &$Func($in, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; - - ok -e $out_file, " Created output file"; - my $got = anyUncompress($out_file, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $buffer, $got, " Uncompressed matches original"; - - } - - { - title "$TopType - From Handle to Buffer content '$disp_content' Append $append" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - writeFile($in_file, $buffer); - my $in = new IO::File "<$in_file" ; - - my $out = $already ; - - ok &$Func($in, \$out, Append => $append), ' Compressed ok' ; - - my $got = anyUncompress(\$out, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $buffer, $got, " Uncompressed matches original"; - - } - - { - title "$TopType - From stdin (via '-') to Buffer content '$disp_content' Append $append" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - writeFile($in_file, $buffer); - - open(SAVEIN, "<&STDIN"); - my $dummy = fileno SAVEIN ; - ok open(STDIN, "<$in_file"), " redirect STDIN"; - - my $out = $already; - - ok &$Func('-', \$out, Append => $append), ' Compressed ok' - or diag $$Error ; - - open(STDIN, "<&SAVEIN"); - - my $got = anyUncompress(\$out, $already); - $got = undef if ! defined $buffer && $got eq '' ; - is $buffer, $got, " Uncompressed matches original"; - - } - - } - } - } - - foreach my $bit ($CompressClass) - { - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $TopTypeInverse = getInverse($bit); - my $FuncInverse = getTopFuncRef($TopTypeInverse); - my $ErrorInverse = getErrorRef($TopTypeInverse); - - my $lex = new LexFile(my $file1, my $file2) ; - - writeFile($file1, "data1"); - writeFile($file2, "data2"); - my $of = new IO::File "<$file1" ; - ok $of, " Created output filehandle" ; - - #my @input = ( undef, "", $file2, \undef, \'', \"abcde", $of) ; - #my @expected = ("", "", $file2, "", "", "abcde", "data1"); - #my @uexpected = ("", "", "data2", "", "", "abcde", "data1"); - #my @input = ( $file2, \"abcde", $of) ; - #my @expected = ( $file2, "abcde", "data1"); - #my @uexpected = ("data2", "abcde", "data1"); - - my @input = ( $file1, $file2) ; - #my @expected = ( $file1, $file2); - my @expected = ("data1", "data2"); - my @uexpected = ("data1", "data2"); - - my @keep = @input ; - - { - title "$TopType - From Array Ref to Array Ref" ; - - my @output = ('first') ; - ok &$Func(\@input, \@output, AutoClose => 0), ' Compressed ok' ; - - is $output[0], 'first', " Array[0] unchanged"; - - is_deeply \@input, \@keep, " Input array not changed" ; - my @got = shift @output; - foreach (@output) { push @got, anyUncompress($_) } - - is_deeply \@got, ['first', @expected], " Got Expected uncompressed data"; - - } - - foreach my $ms (@MultiValues) - { - { - title "$TopType - From Array Ref to Buffer, MultiStream $ms" ; - - # rewind the filehandle - $of->open("<$file1") ; - - my $output ; - ok &$Func(\@input, \$output, MultiStream => $ms, AutoClose => 0), ' Compressed ok' - or diag $$Error; - - my $got = anyUncompress([ \$output, MultiStream => $ms ]); - - is $got, join('', @uexpected), " Got Expected uncompressed data"; - my @headers = getHeaders(\$output); - is @headers, $ms ? @input : 1, " Header count ok"; - } - - { - title "$TopType - From Array Ref to Filename, MultiStream $ms" ; - - my $lex = new LexFile( my $file3) ; - - # rewind the filehandle - $of->open("<$file1") ; - - my $output ; - ok &$Func(\@input, $file3, MultiStream => $ms, AutoClose => 0), ' Compressed ok' ; - - my $got = anyUncompress([ $file3, MultiStream => $ms ]); - - is $got, join('', @uexpected), " Got Expected uncompressed data"; - my @headers = getHeaders($file3); - is @headers, $ms ? @input : 1, " Header count ok"; - } - - { - title "$TopType - From Array Ref to Filehandle, MultiStream $ms" ; - - my $lex = new LexFile(my $file3) ; - - my $fh3 = new IO::File ">$file3"; - - # rewind the filehandle - $of->open("<$file1") ; - - my $output ; - ok &$Func(\@input, $fh3, MultiStream => $ms, AutoClose => 0), ' Compressed ok' ; - - $fh3->close(); - - my $got = anyUncompress([ $file3, MultiStream => $ms ]); - - is $got, join('', @uexpected), " Got Expected uncompressed data"; - my @headers = getHeaders($file3); - is @headers, $ms ? @input : 1, " Header count ok"; - } - - SKIP: - { - title "Truncated file"; - skip '', 7 - if $CompressClass =~ /lzop|lzf/i ; - - my @in ; - push @in, "abcde" x 10; - push @in, "defgh" x 1000; - push @in, "12345" x 50000; - - my $out; - - for (@in) { - ok &$Func(\$_ , \$out, Append => 1 ), ' Compressed ok' - or diag $$Error; - } - #ok &$Func(\@in, \$out, MultiStream => 1 ), ' Compressed ok' - substr($out, -179) = ''; - - my $got; - my $status ; - ok $status = &$FuncInverse(\$out => \$got, MultiStream => 0), " Uncompressed stream 1 ok"; - is $got, "abcde" x 10 ; - ok ! &$FuncInverse(\$out => \$got, MultiStream => 1), " Didn't uncompress"; - is $$ErrorInverse, "unexpected end of file", " Got unexpected eof"; - } - } - } - - foreach my $bit ($UncompressClass, - #'IO::Uncompress::AnyUncompress', - ) - { - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - my $CompressClass = getInverse($bit); - my $C_Func = getTopFuncRef($CompressClass); - - - - my $data = "mary had a little lamb" ; - my $keep = $data ; - my $extra = "after the main event"; - - foreach my $fb ( qw( filehandle buffer ) ) - { - title "Trailingdata with $TopType, from $fb"; - - my $lex = new LexFile my $name ; - my $input ; - - my $compressed ; - ok &$C_Func(\$data, \$compressed), ' Compressed ok' ; - $compressed .= $extra; - - if ($fb eq 'buffer') - { - $input = \$compressed; - } - else - { - writeFile($name, $compressed); - - $input = new IO::File "<$name" ; - } - - my $trailing; - my $out; - ok $Func->($input, \$out, TrailingData => $trailing), " Uncompressed OK" ; - is $out, $keep, " Got uncompressed data"; - - my $rest = ''; - if ($fb eq 'filehandle') - { - read($input, $rest, 10000) ; - } - - is $trailing . $rest, $extra, " Got trailing data"; - - } - } - - -# foreach my $bit ($CompressClass) -# { -# my $Error = getErrorRef($bit); -# my $Func = getTopFuncRef($bit); -# my $TopType = getTopFuncName($bit); -# -# my $TopTypeInverse = getInverse($bit); -# my $FuncInverse = getTopFuncRef($TopTypeInverse); -# -# my @inFiles = map { "in$_.tmp" } 1..4; -# my @outFiles = map { "out$_.tmp" } 1..4; -# my $lex = new LexFile(@inFiles, @outFiles); -# -# writeFile($_, "data $_") foreach @inFiles ; -# -# { -# title "$TopType - Hash Ref: to filename" ; -# -# my $output ; -# ok &$Func( { $inFiles[0] => $outFiles[0], -# $inFiles[1] => $outFiles[1], -# $inFiles[2] => $outFiles[2] } ), ' Compressed ok' ; -# -# foreach (0 .. 2) -# { -# my $got = anyUncompress($outFiles[$_]); -# is $got, "data $inFiles[$_]", " Uncompressed $_ matches original"; -# } -# } -# -# { -# title "$TopType - Hash Ref: to buffer" ; -# -# my @buffer ; -# ok &$Func( { $inFiles[0] => \$buffer[0], -# $inFiles[1] => \$buffer[1], -# $inFiles[2] => \$buffer[2] } ), ' Compressed ok' ; -# -# foreach (0 .. 2) -# { -# my $got = anyUncompress(\$buffer[$_]); -# is $got, "data $inFiles[$_]", " Uncompressed $_ matches original"; -# } -# } -# -# { -# title "$TopType - Hash Ref: to undef" ; -# -# my @buffer ; -# my %hash = ( $inFiles[0] => undef, -# $inFiles[1] => undef, -# $inFiles[2] => undef, -# ); -# -# ok &$Func( \%hash ), ' Compressed ok' ; -# -# foreach (keys %hash) -# { -# my $got = anyUncompress(\$hash{$_}); -# is $got, "data $_", " Uncompressed $_ matches original"; -# } -# } -# -# { -# title "$TopType - Filename to Hash Ref" ; -# -# my %output ; -# ok &$Func( $inFiles[0] => \%output), ' Compressed ok' ; -# -# is keys %output, 1, " one pair in hash" ; -# my ($k, $v) = each %output; -# is $k, $inFiles[0], " key is '$inFiles[0]'"; -# my $got = anyUncompress($v); -# is $got, "data $inFiles[0]", " Uncompressed matches original"; -# } -# -# { -# title "$TopType - File Glob to Hash Ref" ; -# -# my %output ; -# ok &$Func( '<in*.tmp>' => \%output), ' Compressed ok' ; -# -# is keys %output, 4, " four pairs in hash" ; -# foreach my $fil (@inFiles) -# { -# ok exists $output{$fil}, " key '$fil' exists" ; -# my $got = anyUncompress($output{$fil}); -# is $got, "data $fil", " Uncompressed matches original"; -# } -# } -# -# -# } - -# foreach my $bit ($CompressClass) -# { -# my $Error = getErrorRef($bit); -# my $Func = getTopFuncRef($bit); -# my $TopType = getTopFuncName($bit); -# -# my $TopTypeInverse = getInverse($bit); -# my $FuncInverse = getTopFuncRef($TopTypeInverse); -# -# my @inFiles = map { "in$_.tmp" } 1..4; -# my @outFiles = map { "out$_.tmp" } 1..4; -# my $lex = new LexFile(@inFiles, @outFiles); -# -# writeFile($_, "data $_") foreach @inFiles ; -# -# -# -# # if (0) -# # { -# # title "$TopType - Hash Ref to Array Ref" ; -# # -# # my @output = ('first') ; -# # ok &$Func( { \@input, \@output } , AutoClose => 0), ' Compressed ok' ; -# # -# # is $output[0], 'first', " Array[0] unchanged"; -# # -# # is_deeply \@input, \@keep, " Input array not changed" ; -# # my @got = shift @output; -# # foreach (@output) { push @got, anyUncompress($_) } -# # -# # is_deeply \@got, ['first', @expected], " Got Expected uncompressed data"; -# # -# # } -# # -# # if (0) -# # { -# # title "$TopType - From Array Ref to Buffer" ; -# # -# # # rewind the filehandle -# # $of->open("<$file1") ; -# # -# # my $output ; -# # ok &$Func(\@input, \$output, AutoClose => 0), ' Compressed ok' ; -# # -# # my $got = anyUncompress(\$output); -# # -# # is $got, join('', @expected), " Got Expected uncompressed data"; -# # } -# # -# # if (0) -# # { -# # title "$TopType - From Array Ref to Filename" ; -# # -# # my ($file3) = ("file3"); -# # my $lex = new LexFile($file3) ; -# # -# # # rewind the filehandle -# # $of->open("<$file1") ; -# # -# # my $output ; -# # ok &$Func(\@input, $file3, AutoClose => 0), ' Compressed ok' ; -# # -# # my $got = anyUncompress($file3); -# # -# # is $got, join('', @expected), " Got Expected uncompressed data"; -# # } -# # -# # if (0) -# # { -# # title "$TopType - From Array Ref to Filehandle" ; -# # -# # my ($file3) = ("file3"); -# # my $lex = new LexFile($file3) ; -# # -# # my $fh3 = new IO::File ">$file3"; -# # -# # # rewind the filehandle -# # $of->open("<$file1") ; -# # -# # my $output ; -# # ok &$Func(\@input, $fh3, AutoClose => 0), ' Compressed ok' ; -# # -# # $fh3->close(); -# # -# # my $got = anyUncompress($file3); -# # -# # is $got, join('', @expected), " Got Expected uncompressed data"; -# # } -# } - - foreach my $bit ($CompressClass - ) - { - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - for my $files ( [qw(a1)], [qw(a1 a2 a3)] ) - { - - my $tmpDir1 = 'tmpdir1'; - my $tmpDir2 = 'tmpdir2'; - my $lex = new LexDir($tmpDir1, $tmpDir2) ; - - mkdir $tmpDir1, 0777; - mkdir $tmpDir2, 0777; - - ok -d $tmpDir1, " Temp Directory $tmpDir1 exists"; - #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist"; - - my @files = map { "$tmpDir1/$_.tmp" } @$files ; - foreach (@files) { writeFile($_, "abc $_") } - - my @expected = map { "abc $_" } @files ; - my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ; - - { - title "$TopType - From FileGlob to FileGlob files [@$files]" ; - - ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' Compressed ok' - or diag $$Error ; - - my @copy = @expected; - for my $file (@outFiles) - { - is anyUncompress($file), shift @copy, " got expected from $file" ; - } - - is @copy, 0, " got all files"; - } - - { - title "$TopType - From FileGlob to Array files [@$files]" ; - - my @buffer = ('first') ; - ok &$Func("<$tmpDir1/a*.tmp>" => \@buffer), ' Compressed ok' - or diag $$Error ; - - is shift @buffer, 'first'; - - my @copy = @expected; - for my $buffer (@buffer) - { - is anyUncompress($buffer), shift @copy, " got expected " ; - } - - is @copy, 0, " got all files"; - } - - foreach my $ms (@MultiValues) - { - { - title "$TopType - From FileGlob to Buffer files [@$files], MS $ms" ; - - my $buffer ; - ok &$Func("<$tmpDir1/a*.tmp>" => \$buffer, - MultiStream => $ms), ' Compressed ok' - or diag $$Error ; - - #hexDump(\$buffer); - - my $got = anyUncompress([ \$buffer, MultiStream => $ms ]); - - is $got, join("", @expected), " got expected" ; - my @headers = getHeaders(\$buffer); - is @headers, $ms ? @files : 1, " Header count ok"; - } - - { - title "$TopType - From FileGlob to Filename files [@$files], MS $ms" ; - - my $filename = "abcde"; - my $lex = new LexFile($filename) ; - - ok &$Func("<$tmpDir1/a*.tmp>" => $filename, - MultiStream => $ms), ' Compressed ok' - or diag $$Error ; - - #hexDump(\$buffer); - - my $got = anyUncompress([$filename, MultiStream => $ms]); - - is $got, join("", @expected), " got expected" ; - my @headers = getHeaders($filename); - is @headers, $ms ? @files : 1, " Header count ok"; - } - - { - title "$TopType - From FileGlob to Filehandle files [@$files], MS $ms" ; - - my $filename = "abcde"; - my $lex = new LexFile($filename) ; - my $fh = new IO::File ">$filename"; - - ok &$Func("<$tmpDir1/a*.tmp>" => $fh, - MultiStream => $ms, AutoClose => 1), ' Compressed ok' - or diag $$Error ; - - #hexDump(\$buffer); - - my $got = anyUncompress([$filename, MultiStream => $ms]); - - is $got, join("", @expected), " got expected" ; - my @headers = getHeaders($filename); - is @headers, $ms ? @files : 1, " Header count ok"; - } - } - } - - } - - foreach my $bit ($UncompressClass, - 'IO::Uncompress::AnyUncompress', - ) - { - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $buffer = "abcde" ; - my $buffer2 = "ABCDE" ; - my $keep_orig = $buffer; - - my $comp = compressBuffer($UncompressClass, $buffer) ; - my $comp2 = compressBuffer($UncompressClass, $buffer2) ; - my $keep_comp = $comp; - - my $incumbent = "incumbent data" ; - - my @opts = (Strict => 1); - push @opts, (RawInflate => 1) - if $bit eq 'IO::Uncompress::AnyUncompress'; - - for my $append (0, 1) - { - my $expected = $buffer ; - $expected = $incumbent . $buffer if $append ; - - { - title "$TopType - From Buff to Buff, Append($append)" ; - - my $output ; - $output = $incumbent if $append ; - ok &$Func(\$comp, \$output, Append => $append, @opts), ' Uncompressed ok' ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Buff to Array, Append($append)" ; - - my @output = ('first'); - #$output = $incumbent if $append ; - ok &$Func(\$comp, \@output, Append => $append, @opts), ' Uncompressed ok' ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output[0], 'first', " Uncompressed matches original"; - is ${ $output[1] }, $buffer, " Uncompressed matches original" - or diag $output[1] ; - is @output, 2, " only 2 elements in the array" ; - } - - { - title "$TopType - From Buff to Filename, Append($append)" ; - - my $lex = new LexFile(my $out_file) ; - if ($append) - { writeFile($out_file, $incumbent) } - else - { ok ! -e $out_file, " Output file does not exist" } - - ok &$Func(\$comp, $out_file, Append => $append, @opts), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Buff to Handle, Append($append)" ; - - my $lex = new LexFile(my $out_file) ; - my $of ; - if ($append) { - writeFile($out_file, $incumbent) ; - $of = new IO::File "+< $out_file" ; - } - else { - ok ! -e $out_file, " Output file does not exist" ; - $of = new IO::File "> $out_file" ; - } - isa_ok $of, 'IO::File', ' $of' ; - - ok &$Func(\$comp, $of, Append => $append, AutoClose => 1, @opts), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Filename to Filename, Append($append)" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - if ($append) - { writeFile($out_file, $incumbent) } - else - { ok ! -e $out_file, " Output file does not exist" } - - writeFile($in_file, $comp); - - ok &$Func($in_file, $out_file, Append => $append, @opts), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Filename to Handle, Append($append)" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - my $out ; - if ($append) { - writeFile($out_file, $incumbent) ; - $out = new IO::File "+< $out_file" ; - } - else { - ok ! -e $out_file, " Output file does not exist" ; - $out = new IO::File "> $out_file" ; - } - isa_ok $out, 'IO::File', ' $out' ; - - writeFile($in_file, $comp); - - ok &$Func($in_file, $out, Append => $append, AutoClose => 1, @opts), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Filename to Buffer, Append($append)" ; - - my $lex = new LexFile(my $in_file) ; - writeFile($in_file, $comp); - - my $output ; - $output = $incumbent if $append ; - - ok &$Func($in_file, \$output, Append => $append, @opts), ' Uncompressed ok' ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Handle to Filename, Append($append)" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - if ($append) - { writeFile($out_file, $incumbent) } - else - { ok ! -e $out_file, " Output file does not exist" } - - writeFile($in_file, $comp); - my $in = new IO::File "<$in_file" ; - - ok &$Func($in, $out_file, Append => $append, @opts), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Handle to Handle, Append($append)" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - my $out ; - if ($append) { - writeFile($out_file, $incumbent) ; - $out = new IO::File "+< $out_file" ; - } - else { - ok ! -e $out_file, " Output file does not exist" ; - $out = new IO::File "> $out_file" ; - } - isa_ok $out, 'IO::File', ' $out' ; - - writeFile($in_file, $comp); - my $in = new IO::File "<$in_file" ; - - ok &$Func($in, $out, Append => $append, AutoClose => 1, @opts), ' Uncompressed ok' ; - - ok -e $out_file, " Created output file"; - my $content = readFile($out_file) ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $content, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From Filename to Buffer, Append($append)" ; - - my $lex = new LexFile(my $in_file) ; - writeFile($in_file, $comp); - my $in = new IO::File "<$in_file" ; - - my $output ; - $output = $incumbent if $append ; - - ok &$Func($in, \$output, Append => $append, @opts), ' Uncompressed ok' ; - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output, $expected, " Uncompressed matches original"; - } - - { - title "$TopType - From stdin (via '-') to Buffer content, Append($append) " ; - - my $lex = new LexFile(my $in_file) ; - writeFile($in_file, $comp); - - open(SAVEIN, "<&STDIN"); - my $dummy = fileno SAVEIN ; - ok open(STDIN, "<$in_file"), " redirect STDIN"; - - my $output ; - $output = $incumbent if $append ; - - ok &$Func('-', \$output, Append => $append, @opts), ' Uncompressed ok' - or diag $$Error ; - - open(STDIN, "<&SAVEIN"); - - is $keep_comp, $comp, " Input buffer not changed" ; - is $output, $expected, " Uncompressed matches original"; - } - } - - { - title "$TopType - From Handle to Buffer, InputLength" ; - - my $lex = new LexFile(my $in_file, my $out_file) ; - my $out ; - - my $expected = $buffer ; - my $appended = 'appended'; - my $len_appended = length $appended; - writeFile($in_file, $comp . $appended . $comp . $appended) ; - my $in = new IO::File "<$in_file" ; - - ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp, @opts), ' Uncompressed ok' ; - - is $out, $expected, " Uncompressed matches original"; - - my $buff; - is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok"; - is $buff, $appended, " Appended data ok"; - - $out = ''; - ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp, @opts), ' Uncompressed ok' ; - - is $out, $expected, " Uncompressed matches original"; - - $buff = ''; - is $in->read($buff, $len_appended), $len_appended, " Length of Appended data ok"; - is $buff, $appended, " Appended data ok"; - } - - for my $stdin ('-', *STDIN) # , \*STDIN) - { - title "$TopType - From stdin (via $stdin) to Buffer content, InputLength" ; - - my $lex = new LexFile my $in_file ; - my $expected = $buffer ; - my $appended = 'appended'; - my $len_appended = length $appended; - writeFile($in_file, $comp . $appended ) ; - - open(SAVEIN, "<&STDIN"); - my $dummy = fileno SAVEIN ; - ok open(STDIN, "<$in_file"), " redirect STDIN"; - - my $output ; - - ok &$Func($stdin, \$output, Transparent => 0, InputLength => length $comp, @opts), ' Uncompressed ok' - or diag $$Error ; - - my $buff ; - is read(STDIN, $buff, $len_appended), $len_appended, " Length of Appended data ok"; - - is $output, $expected, " Uncompressed matches original"; - is $buff, $appended, " Appended data ok"; - - open(STDIN, "<&SAVEIN"); - } - } - - foreach my $bit ($UncompressClass, - 'IO::Uncompress::AnyUncompress', - ) - { - # TODO -- Add Append mode tests - - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $buffer = "abcde" ; - my $keep_orig = $buffer; - - my $null = compressBuffer($UncompressClass, "") ; - my $undef = compressBuffer($UncompressClass, undef) ; - my $comp = compressBuffer($UncompressClass, $buffer) ; - my $keep_comp = $comp; - - my @opts = (); - @opts = (RawInflate => 1) - if $bit eq 'IO::Uncompress::AnyUncompress'; - - my $incumbent = "incumbent data" ; - - my $lex = new LexFile(my $file1, my $file2) ; - - writeFile($file1, compressBuffer($UncompressClass,"data1")); - writeFile($file2, compressBuffer($UncompressClass,"data2")); - - my $of = new IO::File "<$file1" ; - ok $of, " Created output filehandle" ; - - #my @input = ($file2, \$undef, \$null, \$comp, $of) ; - #my @expected = ('data2', '', '', 'abcde', 'data1'); - my @input = ($file1, $file2); - my @expected = ('data1', 'data2'); - - my @keep = @input ; - - { - title "$TopType - From ArrayRef to Buffer" ; - - my $output ; - ok &$Func(\@input, \$output, AutoClose => 0, @opts), ' UnCompressed ok' ; - - is $output, join('', @expected) - } - - { - title "$TopType - From ArrayRef to Filename" ; - - my $lex = new LexFile my $output; - $of->open("<$file1") ; - - ok &$Func(\@input, $output, AutoClose => 0, @opts), ' UnCompressed ok' ; - - is readFile($output), join('', @expected) - } - - { - title "$TopType - From ArrayRef to Filehandle" ; - - my $lex = new LexFile my $output; - my $fh = new IO::File ">$output" ; - $of->open("<$file1") ; - - ok &$Func(\@input, $fh, AutoClose => 0, @opts), ' UnCompressed ok' ; - $fh->close; - - is readFile($output), join('', @expected) - } - - { - title "$TopType - From Array Ref to Array Ref" ; - - my @output = (\'first') ; - $of->open("<$file1") ; - ok &$Func(\@input, \@output, AutoClose => 0, @opts), ' UnCompressed ok' ; - - is_deeply \@input, \@keep, " Input array not changed" ; - is_deeply [map { defined $$_ ? $$_ : "" } @output], - ['first', @expected], - " Got Expected uncompressed data"; - - } - } - - foreach my $bit ($UncompressClass, - 'IO::Uncompress::AnyUncompress', - ) - { - # TODO -- Add Append mode tests - - my $Error = getErrorRef($bit); - my $Func = getTopFuncRef($bit); - my $TopType = getTopFuncName($bit); - - my $tmpDir1 = 'tmpdir1'; - my $tmpDir2 = 'tmpdir2'; - my $lex = new LexDir($tmpDir1, $tmpDir2) ; - - mkdir $tmpDir1, 0777; - mkdir $tmpDir2, 0777; - - my @opts = (); - @opts = (RawInflate => 1) - if $bit eq 'IO::Uncompress::AnyUncompress'; - - ok -d $tmpDir1, " Temp Directory $tmpDir1 exists"; - #ok ! -d $tmpDir2, " Temp Directory $tmpDir2 does not exist"; - - my @files = map { "$tmpDir1/$_.tmp" } qw( a1 a2 a3) ; - foreach (@files) { writeFile($_, compressBuffer($UncompressClass, "abc $_")) } - - my @expected = map { "abc $_" } @files ; - my @outFiles = map { s/$tmpDir1/$tmpDir2/; $_ } @files ; - - { - title "$TopType - From FileGlob to FileGlob" ; - - ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>", @opts), ' UnCompressed ok' - or diag $$Error ; - - my @copy = @expected; - for my $file (@outFiles) - { - is readFile($file), shift @copy, " got expected from $file" ; - } - - is @copy, 0, " got all files"; - } - - { - title "$TopType - From FileGlob to Arrayref" ; - - my @output = (\'first'); - ok &$Func("<$tmpDir1/a*.tmp>" => \@output, @opts), ' UnCompressed ok' - or diag $$Error ; - - my @copy = ('first', @expected); - for my $data (@output) - { - is $$data, shift @copy, " got expected data" ; - } - - is @copy, 0, " got all files"; - } - - { - title "$TopType - From FileGlob to Buffer" ; - - my $output ; - ok &$Func("<$tmpDir1/a*.tmp>" => \$output, @opts), ' UnCompressed ok' - or diag $$Error ; - - is $output, join('', @expected), " got expected uncompressed data"; - } - - { - title "$TopType - From FileGlob to Filename" ; - - my $lex = new LexFile my $output ; - ok ! -e $output, " $output does not exist" ; - ok &$Func("<$tmpDir1/a*.tmp>" => $output, @opts), ' UnCompressed ok' - or diag $$Error ; - - ok -e $output, " $output does exist" ; - is readFile($output), join('', @expected), " got expected uncompressed data"; - } - - { - title "$TopType - From FileGlob to Filehandle" ; - - my $output = 'abc' ; - my $lex = new LexFile $output ; - my $fh = new IO::File ">$output" ; - ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1, @opts), ' UnCompressed ok' - or diag $$Error ; - - ok -e $output, " $output does exist" ; - is readFile($output), join('', @expected), " got expected uncompressed data"; - } - - } - - foreach my $TopType ($CompressClass - # TODO -- add the inflate classes - ) - { - my $Error = getErrorRef($TopType); - my $Func = getTopFuncRef($TopType); - my $Name = getTopFuncName($TopType); - - title "More write tests" ; - - my $lex = new LexFile(my $file1, my $file2, my $file3) ; - - writeFile($file1, "F1"); - writeFile($file2, "F2"); - writeFile($file3, "F3"); - -# my @data = ( -# [ '[\"ab", \"cd"]', "abcd" ], -# -# [ '[\"a", $fh1, \"bc"]', "aF1bc"], -# ) ; -# -# -# foreach my $data (@data) -# { -# my ($send, $get) = @$data ; -# -# my $fh1 = new IO::File "< $file1" ; -# my $fh2 = new IO::File "< $file2" ; -# my $fh3 = new IO::File "< $file3" ; -# -# title "$send"; -# my ($copy); -# eval "\$copy = $send"; -# my $Answer ; -# ok &$Func($copy, \$Answer), " $Name ok"; -# -# my $got = anyUncompress(\$Answer); -# is $got, $get, " got expected output" ; -# ok ! $$Error, " no error" -# or diag "Error is $$Error"; -# -# } - - title "Array Input Error tests" ; - - my @data = ( - [ '[]', "empty array reference"], - [ '[[]]', "unknown input parameter"], - [ '[[[]]]', "unknown input parameter"], - [ '[[\"ab"], [\"cd"]]', "unknown input parameter"], - [ '[\""]', "not a filename"], - [ '[\undef]', "not a filename"], - [ '[\"abcd"]', "not a filename"], - [ '[\&xx]', "unknown input parameter"], - [ '[$fh2]', "not a filename"], - ) ; - - - foreach my $data (@data) - { - my ($send, $get) = @$data ; - - my $fh1 = new IO::File "< $file1" ; - my $fh2 = new IO::File "< $file2" ; - my $fh3 = new IO::File "< $file3" ; - - title "$send"; - my($copy); - eval "\$copy = $send"; - my $Answer ; - my $a ; - eval { $a = &$Func($copy, \$Answer) }; - ok ! $a, " $Name fails"; - - is $$Error, $get, " got error message"; - - } - - @data = ( - '[""]', - '[undef]', - ) ; - - - foreach my $send (@data) - { - title "$send"; - my($copy); - eval "\$copy = $send"; - my $Answer ; - eval { &$Func($copy, \$Answer) } ; - like $@, mkErr("^$TopFuncName: input filename is undef or null string"), - " got error message"; - - } - } - -} - -# TODO add more error cases - -1; diff --git a/ext/IO-Compress/t/compress/prime.pl b/ext/IO-Compress/t/compress/prime.pl deleted file mode 100644 index 4e804e5b00..0000000000 --- a/ext/IO-Compress/t/compress/prime.pl +++ /dev/null @@ -1,90 +0,0 @@ - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use CompTestUtils; - -our ($extra); - -BEGIN { - # use Test::NoWarnings, if available - $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - -} - -sub run -{ - - my $CompressClass = identify(); - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - - - my $hello = <<EOM ; -hello world -this is a test -some more stuff on this line -ad finally... -EOM - - print "#\n# Testing $UncompressClass\n#\n"; - - my $compressed = mkComplete($CompressClass, $hello); - my $cc = $compressed ; - - plan tests => (length($compressed) * 6 * 7) + 1 + $extra ; - - is anyUncompress(\$cc), $hello ; - - for my $blocksize (1, 2, 13) - { - for my $i (0 .. length($compressed) - 1) - { - for my $useBuf (0 .. 1) - { - print "#\n# BlockSize $blocksize, Length $i, Buffer $useBuf\n#\n" ; - my $lex = new LexFile my $name ; - - my $prime = substr($compressed, 0, $i); - my $rest = substr($compressed, $i); - - my $start ; - if ($useBuf) { - $start = \$rest ; - } - else { - $start = $name ; - writeFile($name, $rest); - } - - #my $gz = new $UncompressClass $name, - my $gz = new $UncompressClass $start, - -Append => 1, - -BlockSize => $blocksize, - -Prime => $prime, - -Transparent => 0 - ; - ok $gz; - ok ! $gz->error() ; - my $un ; - my $status = 1 ; - $status = $gz->read($un) while $status > 0 ; - is $status, 0 ; - ok ! $gz->error() - or print "Error is '" . $gz->error() . "'\n"; - is $un, $hello ; - ok $gz->eof() ; - ok $gz->close() ; - } - } - } -} - -1; diff --git a/ext/IO-Compress/t/compress/tied.pl b/ext/IO-Compress/t/compress/tied.pl deleted file mode 100644 index 80d42b7561..0000000000 --- a/ext/IO-Compress/t/compress/tied.pl +++ /dev/null @@ -1,492 +0,0 @@ - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use CompTestUtils; - -our ($BadPerl, $UncompressClass); - -BEGIN -{ - plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" ) - if $] < 5.005 ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - my $tests ; - $BadPerl = ($] >= 5.006 and $] <= 5.008) ; - - if ($BadPerl) { - $tests = 241 ; - } - else { - $tests = 249 ; - } - - plan tests => $tests + $extra ; - -} - - -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - - - -sub myGZreadFile -{ - my $filename = shift ; - my $init = shift ; - - - my $fil = new $UncompressClass $filename, - -Strict => 1, - -Append => 1 - ; - - my $data ; - $data = $init if defined $init ; - 1 while $fil->read($data) > 0; - - $fil->close ; - return $data ; -} - -sub run -{ - - my $CompressClass = identify(); - $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - - { - next if $BadPerl ; - - - title "Testing $CompressClass"; - - - my $x ; - my $gz = new $CompressClass(\$x); - - my $buff ; - - eval { getc($gz) } ; - like $@, mkErr("^getc Not Available: File opened only for output"); - - eval { read($gz, $buff, 1) } ; - like $@, mkErr("^read Not Available: File opened only for output"); - - eval { <$gz> } ; - like $@, mkErr("^readline Not Available: File opened only for output"); - - } - - { - next if $BadPerl; - $UncompressClass = getInverse($CompressClass); - - title "Testing $UncompressClass"; - - my $gc ; - my $guz = new $CompressClass(\$gc); - $guz->write("abc") ; - $guz->close(); - - my $x ; - my $gz = new $UncompressClass(\$gc); - - my $buff ; - - eval { print $gz "abc" } ; - like $@, mkErr("^print Not Available: File opened only for intput"); - - eval { printf $gz "fmt", "abc" } ; - like $@, mkErr("^printf Not Available: File opened only for intput"); - - #eval { write($gz, $buff, 1) } ; - #like $@, mkErr("^write Not Available: File opened only for intput"); - - } - - { - $UncompressClass = getInverse($CompressClass); - - title "Testing $CompressClass and $UncompressClass"; - - - { - # Write - # these tests come almost 100% from IO::String - - my $lex = new LexFile my $name ; - - my $io = $CompressClass->new($name); - - is $io->tell(), 0 ; - - my $heisan = "Heisan\n"; - print $io $heisan ; - - ok ! $io->eof; - - is $io->tell(), length($heisan) ; - - print($io "a", "b", "c"); - - { - local($\) = "\n"; - print $io "d", "e"; - local($,) = ","; - print $io "f", "g", "h"; - } - - my $foo = "1234567890"; - - ok syswrite($io, $foo, length($foo)) == length($foo) ; - if ( $] < 5.6 ) - { is $io->syswrite($foo, length $foo), length $foo } - else - { is $io->syswrite($foo), length $foo } - ok $io->syswrite($foo, length($foo)) == length $foo; - ok $io->write($foo, length($foo), 5) == 5; - ok $io->write("xxx\n", 100, -1) == 1; - - for (1..3) { - printf $io "i(%d)", $_; - $io->printf("[%d]\n", $_); - } - select $io; - print "\n"; - select STDOUT; - - close $io ; - - ok $io->eof; - - is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . - ("1234567890" x 3) . "67890\n" . - "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; - - - } - - { - # Read - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - my $iow = new $CompressClass $name ; - print $iow $str ; - close $iow; - - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name ; - - ok ! $io->eof, " Not EOF"; - is $io->tell(), 0, " Tell is 0" ; - my @lines = <$io>; - is @lines, 6, " Line is 6" - or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; - is $lines[1], "of a paragraph\n" ; - is join('', @lines), $str ; - is $., 6; - is $io->tell(), length($str) ; - - ok $io->eof; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined(<$io>) || - defined($io->getc) || - read($io, $buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - ok !$io->eof; - my @lines = $io->getlines; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = <$io>; - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = <$io>; - ok $io->eof; - ok @lines == 2 - or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# $lines[0]\n"; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (<$io>) { - push(@lines, $_); - $err++ if $. != ++$no; - } - - ok $err == 0 ; - ok $io->eof; - - ok @lines == 3 - or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test read - - { - my $io = $UncompressClass->new($name); - - - if (! $BadPerl) { - eval { read($io, $buf, -1) } ; - like $@, mkErr("length parameter is negative"); - } - - is read($io, $buf, 0), 0, "Requested 0 bytes" ; - - ok read($io, $buf, 3) == 3 ; - ok $buf eq "Thi"; - - ok sysread($io, $buf, 3, 2) == 3 ; - ok $buf eq "Ths i" - or print "# [$buf]\n" ;; - ok ! $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - } - - { - # Read from non-compressed file - - my $str = <<EOT; -This is an example -of a paragraph - - -and a single line. - -EOT - - my $lex = new LexFile my $name ; - - writeFile($name, $str); - my @tmp; - my $buf; - { - my $io = new $UncompressClass $name, -Transparent => 1 ; - - ok defined $io; - ok ! $io->eof; - ok $io->tell() == 0 ; - my @lines = <$io>; - ok @lines == 6; - ok $lines[1] eq "of a paragraph\n" ; - ok join('', @lines) eq $str ; - ok $. == 6; - ok $io->tell() == length($str) ; - - ok $io->eof; - - ok ! ( defined($io->getline) || - (@tmp = $io->getlines) || - defined(<$io>) || - defined($io->getc) || - read($io, $buf, 100) != 0) ; - } - - - { - local $/; # slurp mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = $io->getlines; - ok $io->eof; - ok @lines == 1 && $lines[0] eq $str; - - $io = $UncompressClass->new($name); - ok ! $io->eof; - my $line = <$io>; - ok $line eq $str; - ok $io->eof; - } - - { - local $/ = ""; # paragraph mode - my $io = $UncompressClass->new($name); - ok ! $io->eof; - my @lines = <$io>; - ok $io->eof; - ok @lines == 2 - or print "# exected 2 lines, got " . scalar(@lines) . "\n"; - ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" - or print "# [$lines[0]]\n" ; - ok $lines[1] eq "and a single line.\n\n"; - } - - { - local $/ = "is"; - my $io = $UncompressClass->new($name); - my @lines = (); - my $no = 0; - my $err = 0; - ok ! $io->eof; - while (<$io>) { - push(@lines, $_); - $err++ if $. != ++$no; - } - - ok $err == 0 ; - ok $io->eof; - - ok @lines == 3 ; - ok join("-", @lines) eq - "This- is- an example\n" . - "of a paragraph\n\n\n" . - "and a single line.\n\n"; - } - - - # Test read - - { - my $io = $UncompressClass->new($name); - - ok read($io, $buf, 3) == 3 ; - ok $buf eq "Thi"; - - ok sysread($io, $buf, 3, 2) == 3 ; - ok $buf eq "Ths i"; - ok ! $io->eof; - - # $io->seek(-4, 2); - # - # ok ! $io->eof; - # - # ok read($io, $buf, 20) == 4 ; - # ok $buf eq "e.\n\n"; - # - # ok read($io, $buf, 20) == 0 ; - # ok $buf eq ""; - # - # ok ! $io->eof; - } - - - } - - { - # Vary the length parameter in a read - - my $str = <<EOT; -x -x -This is an example -of a paragraph - - -and a single line. - -EOT - $str = $str x 100 ; - - - foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) - { - foreach my $trans (0, 1) - { - foreach my $append (0, 1) - { - title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; - - my $lex = new LexFile my $name ; - - if ($trans) { - writeFile($name, $str) ; - } - else { - my $iow = new $CompressClass $name ; - print $iow $str ; - close $iow; - } - - - my $io = $UncompressClass->new($name, - -Append => $append, - -Transparent => $trans); - - my $buf; - - is $io->tell(), 0; - - if ($append) { - 1 while $io->read($buf, $bufsize) > 0; - } - else { - my $tmp ; - $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; - } - is length $buf, length $str; - ok $buf eq $str ; - ok ! $io->error() ; - ok $io->eof; - } - } - } - } - - } -} - -1; diff --git a/ext/IO-Compress/t/compress/truncate.pl b/ext/IO-Compress/t/compress/truncate.pl deleted file mode 100644 index b362fd3b6e..0000000000 --- a/ext/IO-Compress/t/compress/truncate.pl +++ /dev/null @@ -1,169 +0,0 @@ - -use lib 't'; -use strict; -use warnings; -use bytes; - -use Test::More ; -use CompTestUtils; - -sub run -{ - my $CompressClass = identify(); - my $UncompressClass = getInverse($CompressClass); - my $Error = getErrorRef($CompressClass); - my $UnError = getErrorRef($UncompressClass); - -# my $hello = <<EOM ; -#hello world -#this is a test -#some more stuff on this line -#and finally... -#EOM - - # ASCII hex equivalent of the text above. This makes the test - # harness behave identically on an EBCDIC platform. - my $hello = - "\x68\x65\x6c\x6c\x6f\x20\x77\x6f\x72\x6c\x64\x0a\x74\x68\x69\x73" . - "\x20\x69\x73\x20\x61\x20\x74\x65\x73\x74\x0a\x73\x6f\x6d\x65\x20" . - "\x6d\x6f\x72\x65\x20\x73\x74\x75\x66\x66\x20\x6f\x6e\x20\x74\x68" . - "\x69\x73\x20\x6c\x69\x6e\x65\x0a\x61\x6e\x64\x20\x66\x69\x6e\x61" . - "\x6c\x6c\x79\x2e\x2e\x2e\x0a" ; - - my $blocksize = 10 ; - - - my ($info, $compressed) = mkComplete($CompressClass, $hello); - - my $header_size = $info->{HeaderLength}; - my $trailer_size = $info->{TrailerLength}; - my $fingerprint_size = $info->{FingerprintLength}; - ok 1, "Compressed size is " . length($compressed) ; - ok 1, "Fingerprint size is $fingerprint_size" ; - ok 1, "Header size is $header_size" ; - ok 1, "Trailer size is $trailer_size" ; - - for my $trans ( 0 .. 1) - { - title "Truncating $CompressClass, Transparent $trans"; - - - foreach my $i (1 .. $fingerprint_size-1) - { - my $lex = new LexFile my $name ; - - title "Fingerprint Truncation - length $i, Transparent $trans"; - - my $part = substr($compressed, 0, $i); - writeFile($name, $part); - - my $gz = new $UncompressClass $name, - -BlockSize => $blocksize, - -Transparent => $trans; - if ($trans) { - ok $gz; - ok ! $gz->error() ; - my $buff ; - is $gz->read($buff), length($part) ; - ok $buff eq $part ; - ok $gz->eof() ; - $gz->close(); - } - else { - ok !$gz; - } - - } - - # - # Any header corruption past the fingerprint is considered catastrophic - # so even if Transparent is set, it should still fail - # - foreach my $i ($fingerprint_size .. $header_size -1) - { - my $lex = new LexFile my $name ; - - title "Header Truncation - length $i, Transparent $trans"; - - my $part = substr($compressed, 0, $i); - writeFile($name, $part); - ok ! defined new $UncompressClass $name, - -BlockSize => $blocksize, - -Transparent => $trans; - #ok $gz->eof() ; - } - - - foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size) - { - next if $i == 0 ; - - my $lex = new LexFile my $name ; - - title "Compressed Data Truncation - length $i, Transparent $trans"; - - my $part = substr($compressed, 0, $i); - writeFile($name, $part); - ok my $gz = new $UncompressClass $name, - -Strict => 1, - -BlockSize => $blocksize, - -Transparent => $trans - or diag $$UnError; - - my $un ; - my $status = 1 ; - $status = $gz->read($un) while $status > 0 ; - cmp_ok $status, "<", 0 ; - ok $gz->error() ; - ok $gz->eof() ; - $gz->close(); - } - - # RawDeflate does not have a trailer - next if $CompressClass eq 'IO::Compress::RawDeflate' ; - - title "Compressed Trailer Truncation"; - foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 ) - { - foreach my $lax (0, 1) - { - my $lex = new LexFile my $name ; - - ok 1, "Compressed Trailer Truncation - Length $i, Lax $lax, Transparent $trans" ; - my $part = substr($compressed, 0, $i); - writeFile($name, $part); - ok my $gz = new $UncompressClass $name, - -BlockSize => $blocksize, - -Strict => !$lax, - -Append => 1, - -Transparent => $trans; - my $un = ''; - my $status = 1 ; - $status = $gz->read($un) while $status > 0 ; - - if ($lax) - { - is $un, $hello; - is $status, 0 - or diag "Status $status Error is " . $gz->error() ; - ok $gz->eof() - or diag "Status $status Error is " . $gz->error() ; - ok ! $gz->error() ; - } - else - { - cmp_ok $status, "<", 0 - or diag "Status $status Error is " . $gz->error() ; - ok $gz->eof() - or diag "Status $status Error is " . $gz->error() ; - ok $gz->error() ; - } - - $gz->close(); - } - } - } -} - -1; - diff --git a/ext/IO-Compress/t/compress/zlib-generic.pl b/ext/IO-Compress/t/compress/zlib-generic.pl deleted file mode 100644 index 94e5da9f72..0000000000 --- a/ext/IO-Compress/t/compress/zlib-generic.pl +++ /dev/null @@ -1,233 +0,0 @@ - -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 => 49 + $extra ; -} - - - -my $CompressClass = identify(); -my $UncompressClass = getInverse($CompressClass); -my $Error = getErrorRef($CompressClass); -my $UnError = getErrorRef($UncompressClass); - -use Compress::Raw::Zlib; -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - -sub myGZreadFile -{ - my $filename = shift ; - my $init = shift ; - - - my $fil = new $UncompressClass $filename, - -Strict => 1, - -Append => 1 - ; - - my $data = ''; - $data = $init if defined $init ; - 1 while $fil->read($data) > 0; - - $fil->close ; - return $data ; -} - - -{ - - title "Testing $CompressClass Errors"; - -} - - -{ - title "Testing $UncompressClass Errors"; - -} - -{ - title "Testing $CompressClass and $UncompressClass"; - - { - title "flush" ; - - - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - { - my $x ; - ok $x = new $CompressClass $name ; - - ok $x->write($hello), "write" ; - ok $x->flush(Z_FINISH), "flush"; - ok $x->close, "close" ; - } - - { - my $uncomp; - ok my $x = new $UncompressClass $name, -Append => 1 ; - - my $len ; - 1 while ($len = $x->read($uncomp)) > 0 ; - - is $len, 0, "read returned 0"; - - ok $x->close ; - is $uncomp, $hello ; - } - } - - - if ($CompressClass ne 'RawDeflate') - { - # write empty file - #======================================== - - my $buffer = ''; - { - my $x ; - ok $x = new $CompressClass(\$buffer) ; - ok $x->close ; - - } - - my $keep = $buffer ; - my $uncomp= ''; - { - my $x ; - ok $x = new $UncompressClass(\$buffer, Append => 1) ; - - 1 while $x->read($uncomp) > 0 ; - - ok $x->close ; - } - - ok $uncomp eq '' ; - ok $buffer eq $keep ; - - } - - - { - title "inflateSync on plain file"; - - my $hello = "I am a HAL 9000 computer" x 2001 ; - - my $k = new $UncompressClass(\$hello, Transparent => 1); - ok $k ; - - # Skip to the flush point -- no-op for plain file - my $status = $k->inflateSync(); - is $status, 1 - or diag $k->error() ; - - my $rest; - is $k->read($rest, length($hello)), length($hello) - or diag $k->error() ; - ok $rest eq $hello ; - - ok $k->close(); - } - - { - title "$CompressClass: inflateSync for real"; - - # create a deflate stream with flush points - - my $hello = "I am a HAL 9000 computer" x 2001 ; - my $goodbye = "Will I dream?" x 2010; - my ($x, $err, $answer, $X, $Z, $status); - my $Answer ; - - ok ($x = new $CompressClass(\$Answer)); - ok $x ; - - is $x->write($hello), length($hello); - - # create a flush point - ok $x->flush(Z_FULL_FLUSH) ; - - is $x->write($goodbye), length($goodbye); - - ok $x->close() ; - - my $k; - $k = new $UncompressClass(\$Answer, BlockSize => 1); - ok $k ; - - my $initial; - is $k->read($initial, 1), 1 ; - is $initial, substr($hello, 0, 1); - - # Skip to the flush point - $status = $k->inflateSync(); - is $status, 1, " inflateSync returned 1" - or diag $k->error() ; - - my $rest; - is $k->read($rest, length($hello) + length($goodbye)), - length($goodbye) - or diag $k->error() ; - ok $rest eq $goodbye, " got expected output" ; - - ok $k->close(); - } - - { - title "$CompressClass: inflateSync no FLUSH point"; - - # create a deflate stream with flush points - - my $hello = "I am a HAL 9000 computer" x 2001 ; - my ($x, $err, $answer, $X, $Z, $status); - my $Answer ; - - ok ($x = new $CompressClass(\$Answer)); - ok $x ; - - is $x->write($hello), length($hello); - - ok $x->close() ; - - my $k = new $UncompressClass(\$Answer, BlockSize => 1); - ok $k ; - - my $initial; - is $k->read($initial, 1), 1 ; - is $initial, substr($hello, 0, 1); - - # Skip to the flush point - $status = $k->inflateSync(); - is $status, 0 - or diag $k->error() ; - - ok $k->close(); - is $k->inflateSync(), 0 ; - } - -} - - -1; - - - - diff --git a/ext/IO-Compress/t/cz-01version.t b/ext/IO-Compress/t/cz-01version.t deleted file mode 100644 index 9d6f283a52..0000000000 --- a/ext/IO-Compress/t/cz-01version.t +++ /dev/null @@ -1,42 +0,0 @@ -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 ; - -BEGIN -{ - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 2 + $extra ; - - use_ok('Compress::Zlib', 2) ; -} - -# Check zlib_version and ZLIB_VERSION are the same. - -my $zlib_h = ZLIB_VERSION ; -my $libz = Compress::Zlib::zlib_version; - -is($zlib_h, $libz, "ZLIB_VERSION ($zlib_h) matches Compress::Zlib::zlib_version") - or diag <<EOM; - -The version of zlib.h does not match the version of libz - -You have zlib.h version $zlib_h - and libz version $libz - -You probably have two versions of zlib installed on your system. -Try removing the one you don't want to use and rebuild. -EOM - diff --git a/ext/IO-Compress/t/cz-05examples.t b/ext/IO-Compress/t/cz-05examples.t deleted file mode 100644 index 5a8fb33e20..0000000000 --- a/ext/IO-Compress/t/cz-05examples.t +++ /dev/null @@ -1,163 +0,0 @@ -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; -use Compress::Zlib; - -BEGIN -{ - plan(skip_all => "Examples needs Perl 5.005 or better - you have Perl $]" ) - if $] < 5.005 ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 26 + $extra ; -} - - -my $Inc = join " ", map qq["-I$_"] => @INC; -$Inc = '"-MExtUtils::testlib"' - if ! $ENV{PERL_CORE} && eval " require ExtUtils::testlib; " ; - -my $Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; -$Perl = qq["$Perl"] if $^O eq 'MSWin32' ; - -$Perl = "$Perl $Inc -w" ; -my $examples = $ENV{PERL_CORE} ? "../ext/IO-Compress/examples/compress-zlib" - : "./examples/compress-zlib"; - -my $hello1 = <<EOM ; -hello -this is -a test -message -x ttttt -xuuuuuu -the end -EOM - -my @hello1 = grep(s/$/\n/, split(/\n/, $hello1)) ; - -my $hello2 = <<EOM; - -Howdy -this is the -second -file -x ppppp -xuuuuuu -really the end -EOM - -my @hello2 = grep(s/$/\n/, split(/\n/, $hello2)) ; - -my $file1 = "hello1.gz" ; -my $file2 = "hello2.gz" ; -my $stderr = "err.out" ; - -for ($file1, $file2, $stderr) { 1 while unlink $_ } ; - - -my $gz = gzopen($file1, "wb"); -$gz->gzwrite($hello1); -$gz->gzclose(); - -$gz = gzopen($file2, "wb"); -$gz->gzwrite($hello2); -$gz->gzclose(); - -sub check -{ - my $command = shift ; - my $expected = shift ; - - my $stderr = 'err.out'; - 1 while unlink $stderr; - - my $cmd = "$command 2>$stderr"; - my $stdout = `$cmd` ; - - my $aok = 1 ; - - $aok &= is $?, 0, " exit status is 0" ; - - $aok &= is readFile($stderr), '', " no stderr" ; - - $aok &= is $stdout, $expected, " expected content is ok" - if defined $expected ; - - if (! $aok) { - diag "Command line: $cmd"; - my ($file, $line) = (caller)[1,2]; - diag "Test called from $file, line $line"; - } - - 1 while unlink $stderr; -} - -# gzcat -# ##### - -title "gzcat - command line" ; -check "$Perl ${examples}/gzcat $file1 $file2", $hello1 . $hello2; - -title "gzcat - stdin" ; -check "$Perl ${examples}/gzcat <$file1 ", $hello1; - - -# gzgrep -# ###### - -title "gzgrep"; -check "$Perl ${examples}/gzgrep the $file1 $file2", - join('', grep(/the/, @hello1, @hello2)); - -for ($file1, $file2, $stderr) { 1 while unlink $_ } ; - - - -# filtdef/filtinf -# ############## - - -writeFile($file1, $hello1) ; -writeFile($file2, $hello2) ; - -title "filtdef" ; -# there's no way to set binmode on backticks in Win32 so we won't use $a later -check "$Perl ${examples}/filtdef $file1 $file2" ; - -title "filtdef | filtinf"; -check "$Perl ${examples}/filtdef $file1 $file2 | $Perl ${examples}/filtinf", - $hello1 . $hello2; -# gzstream -# ######## - -{ - title "gzstream" ; - writeFile($file1, $hello1) ; - check "$Perl ${examples}/gzstream <$file1 >$file2"; - - title "gzcat" ; - check "$Perl ${examples}/gzcat $file2", $hello1 ; -} - -END -{ - for ($file1, $file2, $stderr) { 1 while unlink $_ } ; -} - diff --git a/ext/IO-Compress/t/cz-06gzsetp.t b/ext/IO-Compress/t/cz-06gzsetp.t deleted file mode 100644 index 0f8d83d5ac..0000000000 --- a/ext/IO-Compress/t/cz-06gzsetp.t +++ /dev/null @@ -1,139 +0,0 @@ -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; - -use Compress::Zlib 2 ; - -use IO::Compress::Gzip ; -use IO::Uncompress::Gunzip ; - -use IO::Compress::Deflate ; -use IO::Uncompress::Inflate ; - -use IO::Compress::RawDeflate ; -use IO::Uncompress::RawInflate ; - -our ($extra); - - -BEGIN -{ - # use Test::NoWarnings, if available - $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; -} - -my $ver = Compress::Zlib::zlib_version(); -plan skip_all => "gzsetparams needs zlib 1.0.6 or better. You have $ver\n" - if ZLIB_VERNUM() < 0x1060 ; - -plan tests => 51 + $extra ; - -# Check zlib_version and ZLIB_VERSION are the same. -is Compress::Zlib::zlib_version, ZLIB_VERSION, - "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; - -{ - # gzsetparams - title "Testing gzsetparams"; - - my $hello = "I am a HAL 9000 computer" x 2001 ; - my $len_hello = length $hello ; - my $goodbye = "Will I dream?" x 2010; - my $len_goodbye = length $goodbye; - - my ($input, $err, $answer, $X, $status, $Answer); - - my $lex = new LexFile my $name ; - ok my $x = gzopen($name, "wb"); - - $input .= $hello; - is $x->gzwrite($hello), $len_hello, "gzwrite returned $len_hello" ; - - # Error cases - eval { $x->gzsetparams() }; - like $@, mkErr('^Usage: Compress::Zlib::gzFile::gzsetparams\(file, level, strategy\)'); - - # Change both Level & Strategy - $status = $x->gzsetparams(Z_BEST_SPEED, Z_HUFFMAN_ONLY) ; - cmp_ok $status, '==', Z_OK, "status is Z_OK"; - - $input .= $goodbye; - is $x->gzwrite($goodbye), $len_goodbye, "gzwrite returned $len_goodbye" ; - - ok ! $x->gzclose, "closed" ; - - ok my $k = gzopen($name, "rb") ; - - # calling gzsetparams on reading is not allowed. - $status = $k->gzsetparams(Z_BEST_SPEED, Z_HUFFMAN_ONLY) ; - cmp_ok $status, '==', Z_STREAM_ERROR, "status is Z_STREAM_ERROR" ; - - my $len = length $input ; - my $uncompressed; - is $len, $k->gzread($uncompressed, $len) ; - - ok $uncompressed eq $input ; - ok $k->gzeof ; - ok ! $k->gzclose ; - ok $k->gzeof ; -} - - -foreach my $CompressClass ('IO::Compress::Gzip', - 'IO::Compress::Deflate', - 'IO::Compress::RawDeflate', - ) -{ - my $UncompressClass = getInverse($CompressClass); - - title "Testing $CompressClass"; - - - # deflateParams - - my $hello = "I am a HAL 9000 computer" x 2001 ; - my $len_hello = length $hello ; - my $goodbye = "Will I dream?" x 2010; - my $len_goodbye = length $goodbye; - - #my ($input, $err, $answer, $X, $status, $Answer); - my $compressed; - - ok my $x = new $CompressClass(\$compressed) ; - - my $input .= $hello; - is $x->write($hello), $len_hello ; - - # Change both Level & Strategy - ok $x->deflateParams(Z_BEST_SPEED, Z_HUFFMAN_ONLY); - - $input .= $goodbye; - is $x->write($goodbye), $len_goodbye ; - - ok $x->close ; - - ok my $k = new $UncompressClass(\$compressed); - - my $len = length $input ; - my $uncompressed; - is $k->read($uncompressed, $len), $len - or diag "$IO::Uncompress::Gunzip::GunzipError" ; - - ok $uncompressed eq $input ; - ok $k->eof ; - ok $k->close ; - ok $k->eof ; -} diff --git a/ext/IO-Compress/t/cz-08encoding.t b/ext/IO-Compress/t/cz-08encoding.t deleted file mode 100644 index f377609e57..0000000000 --- a/ext/IO-Compress/t/cz-08encoding.t +++ /dev/null @@ -1,139 +0,0 @@ -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 -{ - plan skip_all => "Encode is not available" - if $] < 5.006 ; - - eval { require Encode; Encode->import(); }; - - plan skip_all => "Encode is not available" - if $@ ; - - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 29 + $extra ; - - use_ok('Compress::Zlib', 2); -} - - - - -# Check zlib_version and ZLIB_VERSION are the same. -is Compress::Zlib::zlib_version, ZLIB_VERSION, - "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; - - -{ - title "memGzip" ; - # length of this string is 2 characters - my $s = "\x{df}\x{100}"; - - my $cs = Compress::Zlib::memGzip(Encode::encode_utf8($s)); - - # length stored at end of gzip file should be 4 - my ($crc, $len) = unpack ("VV", substr($cs, -8, 8)); - - is $len, 4, " length is 4"; -} - -{ - title "memGunzip when compressed gzip has been encoded" ; - my $s = "hello world" ; - - my $co = Compress::Zlib::memGzip($s); - is Compress::Zlib::memGunzip(my $x = $co), $s, " match uncompressed"; - - utf8::upgrade($co); - - my $un = Compress::Zlib::memGunzip($co); - ok $un, " got uncompressed"; - - is $un, $s, " uncompressed matched original"; -} - -{ - title "compress/uncompress"; - - my $s = "\x{df}\x{100}"; - my $s_copy = $s ; - - my $ces = compress(Encode::encode_utf8($s_copy)); - - ok $ces, " compressed ok" ; - - my $un = Encode::decode_utf8(uncompress($ces)); - is $un, $s, " decode_utf8 ok"; - - utf8::upgrade($ces); - $un = Encode::decode_utf8(uncompress($ces)); - is $un, $s, " decode_utf8 ok"; - -} - -{ - title "gzopen" ; - - my $s = "\x{df}\x{100}"; - my $byte_len = length( Encode::encode_utf8($s) ); - my ($uncomp) ; - - my $lex = new LexFile my $name ; - ok my $fil = gzopen($name, "wb"), " gzopen for write ok" ; - - is $fil->gzwrite(Encode::encode_utf8($s)), $byte_len, " wrote $byte_len bytes" ; - - ok ! $fil->gzclose, " gzclose ok" ; - - ok $fil = gzopen($name, "rb"), " gzopen for read ok" ; - - is $fil->gzread($uncomp), $byte_len, " read $byte_len bytes" ; - is length($uncomp), $byte_len, " uncompress is $byte_len bytes"; - - ok ! $fil->gzclose, "gzclose ok" ; - - is $s, Encode::decode_utf8($uncomp), " decode_utf8 ok" ; -} - -{ - title "Catch wide characters"; - - my $a = "a\xFF\x{100}"; - eval { Compress::Zlib::memGzip($a) }; - like($@, qr/Wide character in memGzip/, " wide characters in memGzip"); - - eval { Compress::Zlib::memGunzip($a) }; - like($@, qr/Wide character in memGunzip/, " wide characters in memGunzip"); - - eval { Compress::Zlib::compress($a) }; - like($@, qr/Wide character in compress/, " wide characters in compress"); - - eval { Compress::Zlib::uncompress($a) }; - like($@, qr/Wide character in uncompress/, " wide characters in uncompress"); - - my $lex = new LexFile my $name ; - ok my $fil = gzopen($name, "wb"), " gzopen for write ok" ; - - eval { $fil->gzwrite($a); } ; - like($@, qr/Wide character in gzwrite/, " wide characters in gzwrite"); - - ok ! $fil->gzclose, " gzclose ok" ; -} - diff --git a/ext/IO-Compress/t/cz-14gzopen.t b/ext/IO-Compress/t/cz-14gzopen.t deleted file mode 100644 index e876143b29..0000000000 --- a/ext/IO-Compress/t/cz-14gzopen.t +++ /dev/null @@ -1,646 +0,0 @@ -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; -use IO::File ; - -BEGIN { - # use Test::NoWarnings, if available - my $extra = 0 ; - $extra = 1 - if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - - plan tests => 255 + $extra ; - - use_ok('Compress::Zlib', 2) ; - use_ok('IO::Compress::Gzip::Constants') ; -} - -{ - # Check zlib_version and ZLIB_VERSION are the same. - is Compress::Zlib::zlib_version, ZLIB_VERSION, - "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; -} - -{ - # gzip tests - #=========== - - #my $name = "test.gz" ; - my $lex = new LexFile my $name ; - - my $hello = <<EOM ; -hello world -this is a test -EOM - - my $len = length $hello ; - - my ($x, $uncomp) ; - - ok my $fil = gzopen($name, "wb") ; - - is $gzerrno, 0, 'gzerrno is 0'; - is $fil->gzerror(), 0, "gzerror() returned 0"; - - is $fil->gztell(), 0, "gztell returned 0"; - is $gzerrno, 0, 'gzerrno is 0'; - - is $fil->gzwrite($hello), $len ; - is $gzerrno, 0, 'gzerrno is 0'; - - is $fil->gztell(), $len, "gztell returned $len"; - is $gzerrno, 0, 'gzerrno is 0'; - - ok ! $fil->gzclose ; - - ok $fil = gzopen($name, "rb") ; - - ok ! $fil->gzeof() ; - is $gzerrno, 0, 'gzerrno is 0'; - is $fil->gztell(), 0; - - is $fil->gzread($uncomp), $len; - - is $fil->gztell(), $len; - ok $fil->gzeof() ; - - # gzread after eof bahavior - - my $xyz = "123" ; - is $fil->gzread($xyz), 0, "gzread returns 0 on eof" ; - is $xyz, "", "gzread on eof zaps the output buffer [Match 1,x behavior]" ; - - ok ! $fil->gzclose ; - ok $fil->gzeof() ; - - ok $hello eq $uncomp ; -} - -{ - title 'check that a number can be gzipped'; - my $lex = new LexFile my $name ; - - - my $number = 7603 ; - my $num_len = 4 ; - - ok my $fil = gzopen($name, "wb") ; - - is $gzerrno, 0; - - is $fil->gzwrite($number), $num_len, "gzwrite returned $num_len" ; - is $gzerrno, 0, 'gzerrno is 0'; - ok ! $fil->gzflush(Z_FINISH) ; - - is $gzerrno, 0, 'gzerrno is 0'; - - ok ! $fil->gzclose ; - - cmp_ok $gzerrno, '==', 0; - - ok $fil = gzopen($name, "rb") ; - - my $uncomp; - ok ((my $x = $fil->gzread($uncomp)) == $num_len) ; - - ok $fil->gzerror() == 0 || $fil->gzerror() == Z_STREAM_END; - ok $gzerrno == 0 || $gzerrno == Z_STREAM_END; - ok $fil->gzeof() ; - - ok ! $fil->gzclose ; - ok $fil->gzeof() ; - - ok $gzerrno == 0 - or print "# gzerrno is $gzerrno\n" ; - - 1 while unlink $name ; - - ok $number == $uncomp ; - ok $number eq $uncomp ; -} - -{ - title "now a bigger gzip test"; - - my $text = 'text' ; - my $lex = new LexFile my $file ; - - - ok my $f = gzopen($file, "wb") ; - - # generate a long random string - my $contents = '' ; - foreach (1 .. 5000) - { $contents .= chr int rand 256 } - - my $len = length $contents ; - - is $f->gzwrite($contents), $len ; - - ok ! $f->gzclose ; - - ok $f = gzopen($file, "rb") ; - - ok ! $f->gzeof() ; - - my $uncompressed ; - is $f->gzread($uncompressed, $len), $len ; - - is $contents, $uncompressed - - or print "# Length orig $len" . - ", Length uncompressed " . length($uncompressed) . "\n" ; - - ok $f->gzeof() ; - ok ! $f->gzclose ; - -} - -{ - title "gzip - readline tests"; - # ====================== - - # first create a small gzipped text file - my $lex = new LexFile my $name ; - - my @text = (<<EOM, <<EOM, <<EOM, <<EOM) ; -this is line 1 -EOM -the second line -EOM -the line after the previous line -EOM -the final line -EOM - - my $text = join("", @text) ; - - ok my $fil = gzopen($name, "wb") ; - is $fil->gzwrite($text), length($text) ; - ok ! $fil->gzclose ; - - # now try to read it back in - ok $fil = gzopen($name, "rb") ; - ok ! $fil->gzeof() ; - my $line = ''; - for my $i (0 .. @text -2) - { - ok $fil->gzreadline($line) > 0; - is $line, $text[$i] ; - ok ! $fil->gzeof() ; - } - - # now read the last line - ok $fil->gzreadline($line) > 0; - is $line, $text[-1] ; - ok $fil->gzeof() ; - - # read past the eof - is $fil->gzreadline($line), 0; - - ok $fil->gzeof() ; - ok ! $fil->gzclose ; - ok $fil->gzeof() ; -} - -{ - title "A text file with a very long line (bigger than the internal buffer)"; - my $lex = new LexFile my $name ; - - my $line1 = ("abcdefghijklmnopq" x 2000) . "\n" ; - my $line2 = "second line\n" ; - my $text = $line1 . $line2 ; - ok my $fil = gzopen($name, "wb"), " gzopen ok" ; - is $fil->gzwrite($text), length $text, " gzwrite ok" ; - ok ! $fil->gzclose, " gzclose" ; - - # now try to read it back in - ok $fil = gzopen($name, "rb"), " gzopen" ; - ok ! $fil->gzeof(), "! eof" ; - my $i = 0 ; - my @got = (); - my $line; - while ($fil->gzreadline($line) > 0) { - $got[$i] = $line ; - ++ $i ; - } - is $i, 2, " looped twice" ; - is $got[0], $line1, " got line 1" ; - is $got[1], $line2, " hot line 2" ; - - ok $fil->gzeof(), " gzeof" ; - ok ! $fil->gzclose, " gzclose" ; - ok $fil->gzeof(), " gzeof" ; -} - -{ - title "a text file which is not termined by an EOL"; - - my $lex = new LexFile my $name ; - - my $line1 = "hello hello, I'm back again\n" ; - my $line2 = "there is no end in sight" ; - - my $text = $line1 . $line2 ; - ok my $fil = gzopen($name, "wb"), " gzopen" ; - is $fil->gzwrite($text), length $text, " gzwrite" ; - ok ! $fil->gzclose, " gzclose" ; - - # now try to read it back in - ok $fil = gzopen($name, "rb"), " gzopen" ; - my @got = () ; - my $i = 0 ; - my $line; - while ($fil->gzreadline($line) > 0) { - $got[$i] = $line ; - ++ $i ; - } - is $i, 2, " got 2 lines" ; - is $got[0], $line1, " line 1 ok" ; - is $got[1], $line2, " line 2 ok" ; - - ok $fil->gzeof(), " gzeof" ; - ok ! $fil->gzclose, " gzclose" ; -} - -{ - - title 'mix gzread and gzreadline'; - - # case 1: read a line, then a block. The block is - # smaller than the internal block used by - # gzreadline - my $lex = new LexFile my $name ; - my $line1 = "hello hello, I'm back again\n" ; - my $line2 = "abc" x 200 ; - my $line3 = "def" x 200 ; - my $line; - - my $text = $line1 . $line2 . $line3 ; - my $fil; - ok $fil = gzopen($name, "wb"), ' gzopen for write ok' ; - is $fil->gzwrite($text), length $text, ' gzwrite ok' ; - is $fil->gztell(), length $text, ' gztell ok' ; - ok ! $fil->gzclose, ' gzclose ok' ; - - # now try to read it back in - ok $fil = gzopen($name, "rb"), ' gzopen for read ok' ; - ok ! $fil->gzeof(), ' !gzeof' ; - cmp_ok $fil->gzreadline($line), '>', 0, ' gzreadline' ; - is $fil->gztell(), length $line1, ' gztell ok' ; - ok ! $fil->gzeof(), ' !gzeof' ; - is $line, $line1, ' got expected line' ; - cmp_ok $fil->gzread($line, length $line2), '>', 0, ' gzread ok' ; - is $fil->gztell(), length($line1)+length($line2), ' gztell ok' ; - ok ! $fil->gzeof(), ' !gzeof' ; - is $line, $line2, ' read expected block' ; - cmp_ok $fil->gzread($line, length $line3), '>', 0, ' gzread ok' ; - is $fil->gztell(), length($text), ' gztell ok' ; - ok $fil->gzeof(), ' !gzeof' ; - is $line, $line3, ' read expected block' ; - ok ! $fil->gzclose, ' gzclose' ; -} - -{ - title "Pass gzopen a filehandle - use IO::File" ; - - my $lex = new LexFile my $name ; - - my $hello = "hello" ; - my $len = length $hello ; - - my $f = new IO::File ">$name" ; - ok $f; - - my $fil; - ok $fil = gzopen($f, "wb") ; - - ok $fil->gzwrite($hello) == $len ; - - ok ! $fil->gzclose ; - - $f = new IO::File "<$name" ; - ok $fil = gzopen($name, "rb") ; - - my $uncomp; my $x; - ok (($x = $fil->gzread($uncomp)) == $len) - or print "# length $x, expected $len\n" ; - - ok $fil->gzeof() ; - ok ! $fil->gzclose ; - ok $fil->gzeof() ; - - is $uncomp, $hello, "got expected output" ; -} - - -{ - title "Pass gzopen a filehandle - use open" ; - - my $lex = new LexFile my $name ; - - my $hello = "hello" ; - my $len = length $hello ; - - open F, ">$name" ; - - my $fil; - ok $fil = gzopen(*F, "wb") ; - - is $fil->gzwrite($hello), $len ; - - ok ! $fil->gzclose ; - - open F, "<$name" ; - ok $fil = gzopen(*F, "rb") ; - - my $uncomp; my $x; - $x = $fil->gzread($uncomp); - is $x, $len ; - - ok $fil->gzeof() ; - ok ! $fil->gzclose ; - ok $fil->gzeof() ; - - is $uncomp, $hello ; - - -} - -foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) -{ - my $stdin = $stdio->[0]; - my $stdout = $stdio->[1]; - - title "Pass gzopen a filehandle - use $stdin" ; - - my $lex = new LexFile my $name ; - - my $hello = "hello" ; - my $len = length $hello ; - - ok open(SAVEOUT, ">&STDOUT"), " save STDOUT"; - my $dummy = fileno SAVEOUT; - ok open(STDOUT, ">$name"), " redirect STDOUT" ; - - my $status = 0 ; - - my $fil = gzopen($stdout, "wb") ; - - $status = $fil && - ($fil->gzwrite($hello) == $len) && - ($fil->gzclose == 0) ; - - open(STDOUT, ">&SAVEOUT"); - - ok $status, " wrote to stdout"; - - open(SAVEIN, "<&STDIN"); - ok open(STDIN, "<$name"), " redirect STDIN"; - $dummy = fileno SAVEIN; - - ok $fil = gzopen($stdin, "rb") ; - - my $uncomp; my $x; - ok (($x = $fil->gzread($uncomp)) == $len) - or print "# length $x, expected $len\n" ; - - ok $fil->gzeof() ; - ok ! $fil->gzclose ; - ok $fil->gzeof() ; - - open(STDIN, "<&SAVEIN"); - - is $uncomp, $hello ; - - -} - -{ - title 'test parameters for gzopen'; - my $lex = new LexFile my $name ; - - my $fil; - - # missing parameters - eval ' $fil = gzopen() ' ; - like $@, mkEvalErr('Not enough arguments for Compress::Zlib::gzopen'), - ' gzopen with missing mode fails' ; - - # unknown parameters - $fil = gzopen($name, "xy") ; - ok ! defined $fil, ' gzopen with unknown mode fails' ; - - $fil = gzopen($name, "ab") ; - ok $fil, ' gzopen with mode "ab" is ok' ; - - $fil = gzopen($name, "wb6") ; - ok $fil, ' gzopen with mode "wb6" is ok' ; - - $fil = gzopen($name, "wbf") ; - ok $fil, ' gzopen with mode "wbf" is ok' ; - - $fil = gzopen($name, "wbh") ; - ok $fil, ' gzopen with mode "wbh" is ok' ; -} - -{ - title 'Read operations when opened for writing'; - - my $lex = new LexFile my $name ; - my $fil; - ok $fil = gzopen($name, "wb"), ' gzopen for writing' ; - ok !$fil->gzeof(), ' !eof'; ; - is $fil->gzread(), Z_STREAM_ERROR, " gzread returns Z_STREAM_ERROR" ; - ok ! $fil->gzclose, " gzclose ok" ; -} - -{ - title 'write operations when opened for reading'; - - my $lex = new LexFile my $name ; - my $text = "hello" ; - my $fil; - ok $fil = gzopen($name, "wb"), " gzopen for writing" ; - is $fil->gzwrite($text), length $text, " gzwrite ok" ; - ok ! $fil->gzclose, " gzclose ok" ; - - ok $fil = gzopen($name, "rb"), " gzopen for reading" ; - is $fil->gzwrite(), Z_STREAM_ERROR, " gzwrite returns Z_STREAM_ERROR" ; -} - -{ - title 'read/write a non-readable/writable file'; - - SKIP: - { - my $lex = new LexFile my $name ; - writeFile($name, "abc"); - chmod 0444, $name ; - - skip "Cannot create non-writable file", 3 - if -w $name ; - - ok ! -w $name, " input file not writable"; - - my $fil = gzopen($name, "wb") ; - ok !$fil, " gzopen returns undef" ; - ok $gzerrno, " gzerrno ok" or - diag " gzerrno $gzerrno\n"; - - chmod 0777, $name ; - } - - SKIP: - { - my $lex = new LexFile my $name ; - skip "Cannot create non-readable file", 3 - if $^O eq 'cygwin'; - - writeFile($name, "abc"); - chmod 0222, $name ; - - skip "Cannot create non-readable file", 3 - if -r $name ; - - ok ! -r $name, " input file not readable"; - $gzerrno = 0; - my $fil = gzopen($name, "rb") ; - ok !$fil, " gzopen returns undef" ; - ok $gzerrno, " gzerrno ok"; - chmod 0777, $name ; - } - -} - -{ - title "gzseek" ; - - my $buff ; - my $lex = new LexFile my $name ; - - my $first = "beginning" ; - my $last = "the end" ; - my $iow = gzopen($name, "w"); - $iow->gzwrite($first) ; - ok $iow->gzseek(5, SEEK_CUR) ; - is $iow->gztell(), length($first)+5; - ok $iow->gzseek(0, SEEK_CUR) ; - is $iow->gztell(), length($first)+5; - ok $iow->gzseek(length($first)+10, SEEK_SET) ; - is $iow->gztell(), length($first)+10; - - $iow->gzwrite($last) ; - $iow->gzclose ; - - ok GZreadFile($name) eq $first . "\x00" x 10 . $last ; - - my $io = gzopen($name, "r"); - ok $io->gzseek(length($first), SEEK_CUR) ; - ok ! $io->gzeof; - is $io->gztell(), length($first); - - ok $io->gzread($buff, 5) ; - is $buff, "\x00" x 5 ; - is $io->gztell(), length($first) + 5; - - is $io->gzread($buff, 0), 0 ; - #is $buff, "\x00" x 5 ; - is $io->gztell(), length($first) + 5; - - ok $io->gzseek(0, SEEK_CUR) ; - my $here = $io->gztell() ; - is $here, length($first)+5; - - ok $io->gzseek($here+5, SEEK_SET) ; - is $io->gztell(), $here+5 ; - ok $io->gzread($buff, 100) ; - ok $buff eq $last ; - ok $io->gzeof; -} - -{ - # seek error cases - my $lex = new LexFile my $name ; - - my $a = gzopen($name, "w"); - - ok ! $a->gzerror() - or print "# gzerrno is $Compress::Zlib::gzerrno \n" ; - eval { $a->gzseek(-1, 10) ; }; - like $@, mkErr("gzseek: unknown value, 10, for whence parameter"); - - eval { $a->gzseek(-1, SEEK_END) ; }; - like $@, mkErr("gzseek: cannot seek backwards"); - - $a->gzwrite("fred"); - $a->gzclose ; - - - my $u = gzopen($name, "r"); - - eval { $u->gzseek(-1, 10) ; }; - like $@, mkErr("gzseek: unknown value, 10, for whence parameter"); - - eval { $u->gzseek(-1, SEEK_END) ; }; - like $@, mkErr("gzseek: SEEK_END not allowed"); - - eval { $u->gzseek(-1, SEEK_CUR) ; }; - like $@, mkErr("gzseek: cannot seek backwards"); -} - -{ - title "gzread ver 1.x compat -- the output buffer is always zapped."; - my $lex = new LexFile my $name ; - - my $a = gzopen($name, "w"); - $a->gzwrite("fred"); - $a->gzclose ; - - my $u = gzopen($name, "r"); - - my $buf1 ; - is $u->gzread($buf1, 0), 0, " gzread returns 0"; - ok defined $buf1, " output buffer defined"; - is $buf1, "", " output buffer empty string"; - - my $buf2 = "qwerty"; - is $u->gzread($buf2, 0), 0, " gzread returns 0"; - ok defined $buf2, " output buffer defined"; - is $buf2, "", " output buffer empty string"; -} - -{ - title 'gzreadline does not support $/'; - - my $lex = new LexFile my $name ; - - my $a = gzopen($name, "w"); - my $text = "fred\n"; - my $len = length $text; - $a->gzwrite($text); - $a->gzwrite("\n\n"); - $a->gzclose ; - - for my $delim ( undef, "", 0, 1, "abc", $text, "\n\n", "\n" ) - { - local $/ = $delim; - my $u = gzopen($name, "r"); - my $line; - is $u->gzreadline($line), length $text, " read $len bytes"; - is $line, $text, " got expected line"; - ok ! $u->gzclose, " closed" ; - is $/, $delim, ' $/ unchanged by gzreadline'; - } -} diff --git a/ext/IO-Compress/t/globmapper.t b/ext/IO-Compress/t/globmapper.t deleted file mode 100644 index 10a4d88716..0000000000 --- a/ext/IO-Compress/t/globmapper.t +++ /dev/null @@ -1,304 +0,0 @@ -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 - |