diff options
Diffstat (limited to 'cpan')
143 files changed, 34592 insertions, 0 deletions
diff --git a/cpan/IO-Compress/Changes b/cpan/IO-Compress/Changes new file mode 100644 index 0000000000..6460a72849 --- /dev/null +++ b/cpan/IO-Compress/Changes @@ -0,0 +1,874 @@ +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/cpan/IO-Compress/Makefile.PL b/cpan/IO-Compress/Makefile.PL new file mode 100644 index 0000000000..64cdd29dac --- /dev/null +++ b/cpan/IO-Compress/Makefile.PL @@ -0,0 +1,56 @@ +#! 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/cpan/IO-Compress/README b/cpan/IO-Compress/README new file mode 100644 index 0000000000..67cc0c6ed4 --- /dev/null +++ b/cpan/IO-Compress/README @@ -0,0 +1,103 @@ + + 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/cpan/IO-Compress/examples/compress-zlib/filtdef b/cpan/IO-Compress/examples/compress-zlib/filtdef new file mode 100755 index 0000000000..57dfeb9068 --- /dev/null +++ b/cpan/IO-Compress/examples/compress-zlib/filtdef @@ -0,0 +1,29 @@ +#!/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/cpan/IO-Compress/examples/compress-zlib/filtinf b/cpan/IO-Compress/examples/compress-zlib/filtinf new file mode 100755 index 0000000000..1df202b1d7 --- /dev/null +++ b/cpan/IO-Compress/examples/compress-zlib/filtinf @@ -0,0 +1,28 @@ +#!/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/cpan/IO-Compress/examples/compress-zlib/gzcat b/cpan/IO-Compress/examples/compress-zlib/gzcat new file mode 100755 index 0000000000..5241a5a11f --- /dev/null +++ b/cpan/IO-Compress/examples/compress-zlib/gzcat @@ -0,0 +1,27 @@ +#!/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/cpan/IO-Compress/examples/compress-zlib/gzgrep b/cpan/IO-Compress/examples/compress-zlib/gzgrep new file mode 100755 index 0000000000..324d3e615f --- /dev/null +++ b/cpan/IO-Compress/examples/compress-zlib/gzgrep @@ -0,0 +1,27 @@ +#!/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/cpan/IO-Compress/examples/compress-zlib/gzstream b/cpan/IO-Compress/examples/compress-zlib/gzstream new file mode 100755 index 0000000000..faacb0a0dd --- /dev/null +++ b/cpan/IO-Compress/examples/compress-zlib/gzstream @@ -0,0 +1,19 @@ +#!/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/cpan/IO-Compress/examples/io/anycat b/cpan/IO-Compress/examples/io/anycat new file mode 100755 index 0000000000..9db9c41faf --- /dev/null +++ b/cpan/IO-Compress/examples/io/anycat @@ -0,0 +1,17 @@ +#!/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/cpan/IO-Compress/examples/io/bzip2/bzcat b/cpan/IO-Compress/examples/io/bzip2/bzcat new file mode 100755 index 0000000000..81123200c5 --- /dev/null +++ b/cpan/IO-Compress/examples/io/bzip2/bzcat @@ -0,0 +1,29 @@ +#!/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/cpan/IO-Compress/examples/io/bzip2/bzgrep b/cpan/IO-Compress/examples/io/bzip2/bzgrep new file mode 100755 index 0000000000..ceb4e8412b --- /dev/null +++ b/cpan/IO-Compress/examples/io/bzip2/bzgrep @@ -0,0 +1,25 @@ +#!/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/cpan/IO-Compress/examples/io/bzip2/bzstream b/cpan/IO-Compress/examples/io/bzip2/bzstream new file mode 100755 index 0000000000..3e88d68258 --- /dev/null +++ b/cpan/IO-Compress/examples/io/bzip2/bzstream @@ -0,0 +1,9 @@ +#!/usr/local/bin/perl + +use strict ; +use warnings ; +use IO::Compress::Bzip2 qw(:all); + +bzip2 '-' => '-' + or die "bzstream: $Bzip2Error\n" ; + diff --git a/cpan/IO-Compress/examples/io/gzip/gzappend b/cpan/IO-Compress/examples/io/gzip/gzappend new file mode 100644 index 0000000000..a4a60a9aad --- /dev/null +++ b/cpan/IO-Compress/examples/io/gzip/gzappend @@ -0,0 +1,24 @@ +#!/usr/local/bin/perl + +use IO::Compress::Gzip qw( $GzipError ); +use strict ; +use warnings ; + +die "Usage: gzappend gz-file file...\n" + unless @ARGV ; + + +my $output = shift @ARGV ; + +@ARGV = '-' unless @ARGV ; + +my $gz = new IO::Compress::Gzip $output, Merge => 1 + or die "Cannot open $output: $GzipError\n" ; + +$gz->write( [@ARGV] ) + or die "Cannot open $output: $GzipError\n" ; + +$gz->close; + + + diff --git a/cpan/IO-Compress/examples/io/gzip/gzcat b/cpan/IO-Compress/examples/io/gzip/gzcat new file mode 100755 index 0000000000..5572bae959 --- /dev/null +++ b/cpan/IO-Compress/examples/io/gzip/gzcat @@ -0,0 +1,29 @@ +#!/usr/local/bin/perl + +use IO::Uncompress::Gunzip qw( $GunzipError ); +use strict ; +use warnings ; + +#die "Usage: gzcat file...\n" +# unless @ARGV ; + +my $file ; +my $buffer ; +my $s; + +@ARGV = '-' unless @ARGV ; + +foreach $file (@ARGV) { + + my $gz = new IO::Uncompress::Gunzip $file + or die "Cannot open $file: $GunzipError\n" ; + + print $buffer + while ($s = $gz->read($buffer)) > 0 ; + + die "Error reading from $file: $GunzipError\n" + if $s < 0 ; + + $gz->close() ; +} + diff --git a/cpan/IO-Compress/examples/io/gzip/gzgrep b/cpan/IO-Compress/examples/io/gzip/gzgrep new file mode 100755 index 0000000000..33820ba064 --- /dev/null +++ b/cpan/IO-Compress/examples/io/gzip/gzgrep @@ -0,0 +1,40 @@ +#!/usr/bin/perl + +use strict ; +use warnings ; +use IO::Uncompress::Gunzip qw($GunzipError); + +die "Usage: gzgrep pattern [file...]\n" + unless @ARGV >= 1; + +my $pattern = shift ; +my $file ; + +@ARGV = '-' unless @ARGV ; + +foreach $file (@ARGV) { + my $gz = new IO::Uncompress::Gunzip $file + or die "Cannot uncompress $file: $GunzipError\n" ; + + while (<$gz>) { + print if /$pattern/ ; + } + + die "Error reading from $file: $GunzipError\n" + if $GunzipError ; +} + +__END__ +foreach $file (@ARGV) { + my $gz = gzopen($file, "rb") + or die "Cannot open $file: $gzerrno\n" ; + + while ($gz->gzreadline($_) > 0) { + print if /$pattern/ ; + } + + die "Error reading from $file: $gzerrno\n" + if $gzerrno != Z_STREAM_END ; + + $gz->gzclose() ; +} diff --git a/cpan/IO-Compress/examples/io/gzip/gzstream b/cpan/IO-Compress/examples/io/gzip/gzstream new file mode 100755 index 0000000000..9d03bc5749 --- /dev/null +++ b/cpan/IO-Compress/examples/io/gzip/gzstream @@ -0,0 +1,24 @@ +#!/usr/local/bin/perl + +use strict ; +use warnings ; +use IO::Compress::Gzip qw(gzip $GzipError); + +gzip '-' => '-', Minimal => 1 + or die "gzstream: $GzipError\n" ; + +#exit 0; + +__END__ + +#my $gz = new IO::Compress::Gzip *STDOUT +my $gz = new IO::Compress::Gzip '-' + or die "gzstream: Cannot open stdout as gzip stream: $GzipError\n" ; + +while (<>) { + $gz->write($_) + or die "gzstream: Error writing gzip output stream: $GzipError\n" ; +} + +$gz->close + or die "gzstream: Error closing gzip output stream: $GzipError\n" ; diff --git a/cpan/IO-Compress/lib/Compress/Zlib.pm b/cpan/IO-Compress/lib/Compress/Zlib.pm new file mode 100644 index 0000000000..0a611039b8 --- /dev/null +++ b/cpan/IO-Compress/lib/Compress/Zlib.pm @@ -0,0 +1,1461 @@ + +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/cpan/IO-Compress/lib/File/GlobMapper.pm b/cpan/IO-Compress/lib/File/GlobMapper.pm new file mode 100644 index 0000000000..40a606309e --- /dev/null +++ b/cpan/IO-Compress/lib/File/GlobMapper.pm @@ -0,0 +1,679 @@ +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/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm new file mode 100644 index 0000000000..a56331d2cb --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm @@ -0,0 +1,162 @@ +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/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm new file mode 100644 index 0000000000..525868093c --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm @@ -0,0 +1,165 @@ +package IO::Compress::Adapter::Deflate ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 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/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm new file mode 100644 index 0000000000..c980e6c343 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm @@ -0,0 +1,101 @@ +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/cpan/IO-Compress/lib/IO/Compress/Base.pm b/cpan/IO-Compress/lib/IO/Compress/Base.pm new file mode 100644 index 0000000000..7b558eafeb --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Base.pm @@ -0,0 +1,981 @@ + +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/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm b/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm new file mode 100644 index 0000000000..7981585d49 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm @@ -0,0 +1,956 @@ +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/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm b/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm new file mode 100644 index 0000000000..e5f86b2f36 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm @@ -0,0 +1,758 @@ +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/cpan/IO-Compress/lib/IO/Compress/Deflate.pm b/cpan/IO-Compress/lib/IO/Compress/Deflate.pm new file mode 100644 index 0000000000..7ee0a53997 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Deflate.pm @@ -0,0 +1,889 @@ +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/cpan/IO-Compress/lib/IO/Compress/Gzip.pm b/cpan/IO-Compress/lib/IO/Compress/Gzip.pm new file mode 100644 index 0000000000..5ddfad20b9 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Gzip.pm @@ -0,0 +1,1201 @@ + +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/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm new file mode 100644 index 0000000000..826183680e --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm @@ -0,0 +1,148 @@ +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/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm b/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm new file mode 100644 index 0000000000..ad642dbfa5 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm @@ -0,0 +1,976 @@ +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/cpan/IO-Compress/lib/IO/Compress/Zip.pm b/cpan/IO-Compress/lib/IO/Compress/Zip.pm new file mode 100644 index 0000000000..563b10d9bf --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Zip.pm @@ -0,0 +1,1570 @@ +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/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm new file mode 100644 index 0000000000..d16eb238ef --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm @@ -0,0 +1,105 @@ +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/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm new file mode 100644 index 0000000000..d65fedc580 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm @@ -0,0 +1,77 @@ + +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/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm b/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm new file mode 100644 index 0000000000..72b4ddd370 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm @@ -0,0 +1,198 @@ +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/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm new file mode 100644 index 0000000000..b2053aff10 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm @@ -0,0 +1,112 @@ +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/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm new file mode 100644 index 0000000000..0df174320a --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm @@ -0,0 +1,105 @@ +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/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm new file mode 100644 index 0000000000..d03148c0b4 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm @@ -0,0 +1,158 @@ +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/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm new file mode 100644 index 0000000000..e8ffc5c15b --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm @@ -0,0 +1,946 @@ +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/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm b/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm new file mode 100644 index 0000000000..cc1ba24b47 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm @@ -0,0 +1,960 @@ +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/cpan/IO-Compress/lib/IO/Uncompress/Base.pm b/cpan/IO-Compress/lib/IO/Uncompress/Base.pm new file mode 100644 index 0000000000..8459ce0e05 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/Base.pm @@ -0,0 +1,1474 @@ + +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/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm b/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm new file mode 100644 index 0000000000..ce483ea738 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm @@ -0,0 +1,858 @@ +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/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm b/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm new file mode 100644 index 0000000000..8922865d43 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm @@ -0,0 +1,1070 @@ + +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/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm new file mode 100644 index 0000000000..20aecc7864 --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm @@ -0,0 +1,941 @@ +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/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm new file mode 100644 index 0000000000..5727192e7c --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm @@ -0,0 +1,1069 @@ +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/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm b/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm new file mode 100644 index 0000000000..7d08c84edc --- /dev/null +++ b/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm @@ -0,0 +1,1508 @@ +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/cpan/IO-Compress/pod/FAQ.pod b/cpan/IO-Compress/pod/FAQ.pod new file mode 100644 index 0000000000..0fee2a9f6d --- /dev/null +++ b/cpan/IO-Compress/pod/FAQ.pod @@ -0,0 +1,512 @@ + +=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/cpan/IO-Compress/private/MakeUtil.pm b/cpan/IO-Compress/private/MakeUtil.pm new file mode 100644 index 0000000000..47aebd6074 --- /dev/null +++ b/cpan/IO-Compress/private/MakeUtil.pm @@ -0,0 +1,381 @@ +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/cpan/IO-Compress/t/000prereq.t b/cpan/IO-Compress/t/000prereq.t new file mode 100644 index 0000000000..11b84fd85e --- /dev/null +++ b/cpan/IO-Compress/t/000prereq.t @@ -0,0 +1,98 @@ +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/cpan/IO-Compress/t/001bzip2.t b/cpan/IO-Compress/t/001bzip2.t new file mode 100644 index 0000000000..40b9bcca59 --- /dev/null +++ b/cpan/IO-Compress/t/001bzip2.t @@ -0,0 +1,206 @@ +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/cpan/IO-Compress/t/001zlib-generic-deflate.t b/cpan/IO-Compress/t/001zlib-generic-deflate.t new file mode 100644 index 0000000000..a988ab9791 --- /dev/null +++ b/cpan/IO-Compress/t/001zlib-generic-deflate.t @@ -0,0 +1,20 @@ +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/cpan/IO-Compress/t/001zlib-generic-gzip.t b/cpan/IO-Compress/t/001zlib-generic-gzip.t new file mode 100644 index 0000000000..db9101d91f --- /dev/null +++ b/cpan/IO-Compress/t/001zlib-generic-gzip.t @@ -0,0 +1,20 @@ +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/cpan/IO-Compress/t/001zlib-generic-rawdeflate.t b/cpan/IO-Compress/t/001zlib-generic-rawdeflate.t new file mode 100644 index 0000000000..4c491eb3a2 --- /dev/null +++ b/cpan/IO-Compress/t/001zlib-generic-rawdeflate.t @@ -0,0 +1,20 @@ +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/cpan/IO-Compress/t/001zlib-generic-zip.t b/cpan/IO-Compress/t/001zlib-generic-zip.t new file mode 100644 index 0000000000..a9c755537f --- /dev/null +++ b/cpan/IO-Compress/t/001zlib-generic-zip.t @@ -0,0 +1,20 @@ +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/cpan/IO-Compress/t/002any-deflate.t b/cpan/IO-Compress/t/002any-deflate.t new file mode 100644 index 0000000000..6a4387ef0c --- /dev/null +++ b/cpan/IO-Compress/t/002any-deflate.t @@ -0,0 +1,29 @@ +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/cpan/IO-Compress/t/002any-gzip.t b/cpan/IO-Compress/t/002any-gzip.t new file mode 100644 index 0000000000..e93625fdfa --- /dev/null +++ b/cpan/IO-Compress/t/002any-gzip.t @@ -0,0 +1,29 @@ +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/cpan/IO-Compress/t/002any-rawdeflate.t b/cpan/IO-Compress/t/002any-rawdeflate.t new file mode 100644 index 0000000000..ef716c60c1 --- /dev/null +++ b/cpan/IO-Compress/t/002any-rawdeflate.t @@ -0,0 +1,28 @@ +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/cpan/IO-Compress/t/002any-transparent.t b/cpan/IO-Compress/t/002any-transparent.t new file mode 100644 index 0000000000..bb26bbcac0 --- /dev/null +++ b/cpan/IO-Compress/t/002any-transparent.t @@ -0,0 +1,72 @@ +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/cpan/IO-Compress/t/002any-zip.t b/cpan/IO-Compress/t/002any-zip.t new file mode 100644 index 0000000000..27f1714899 --- /dev/null +++ b/cpan/IO-Compress/t/002any-zip.t @@ -0,0 +1,29 @@ +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/cpan/IO-Compress/t/004gziphdr.t b/cpan/IO-Compress/t/004gziphdr.t new file mode 100644 index 0000000000..210d499a65 --- /dev/null +++ b/cpan/IO-Compress/t/004gziphdr.t @@ -0,0 +1,962 @@ +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/cpan/IO-Compress/t/005defhdr.t b/cpan/IO-Compress/t/005defhdr.t new file mode 100644 index 0000000000..990b79b3f1 --- /dev/null +++ b/cpan/IO-Compress/t/005defhdr.t @@ -0,0 +1,349 @@ +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/cpan/IO-Compress/t/006zip.t b/cpan/IO-Compress/t/006zip.t new file mode 100644 index 0000000000..2dfa52cabb --- /dev/null +++ b/cpan/IO-Compress/t/006zip.t @@ -0,0 +1,275 @@ +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/cpan/IO-Compress/t/010examples-bzip2.t b/cpan/IO-Compress/t/010examples-bzip2.t new file mode 100644 index 0000000000..9bb5eb20e7 --- /dev/null +++ b/cpan/IO-Compress/t/010examples-bzip2.t @@ -0,0 +1,145 @@ +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/cpan/IO-Compress/t/010examples-zlib.t b/cpan/IO-Compress/t/010examples-zlib.t new file mode 100644 index 0000000000..712c0b4934 --- /dev/null +++ b/cpan/IO-Compress/t/010examples-zlib.t @@ -0,0 +1,145 @@ +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/cpan/IO-Compress/t/01misc.t b/cpan/IO-Compress/t/01misc.t new file mode 100644 index 0000000000..a7a31fbe15 --- /dev/null +++ b/cpan/IO-Compress/t/01misc.t @@ -0,0 +1,314 @@ +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/cpan/IO-Compress/t/020isize.t b/cpan/IO-Compress/t/020isize.t new file mode 100644 index 0000000000..c600c95f34 --- /dev/null +++ b/cpan/IO-Compress/t/020isize.t @@ -0,0 +1,158 @@ +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/cpan/IO-Compress/t/050interop-gzip.t b/cpan/IO-Compress/t/050interop-gzip.t new file mode 100644 index 0000000000..22be0646c8 --- /dev/null +++ b/cpan/IO-Compress/t/050interop-gzip.t @@ -0,0 +1,143 @@ +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/cpan/IO-Compress/t/100generic-bzip2.t b/cpan/IO-Compress/t/100generic-bzip2.t new file mode 100644 index 0000000000..a9f430e236 --- /dev/null +++ b/cpan/IO-Compress/t/100generic-bzip2.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/100generic-deflate.t b/cpan/IO-Compress/t/100generic-deflate.t new file mode 100644 index 0000000000..999c9561e2 --- /dev/null +++ b/cpan/IO-Compress/t/100generic-deflate.t @@ -0,0 +1,22 @@ +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/cpan/IO-Compress/t/100generic-gzip.t b/cpan/IO-Compress/t/100generic-gzip.t new file mode 100644 index 0000000000..614945ca80 --- /dev/null +++ b/cpan/IO-Compress/t/100generic-gzip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/100generic-rawdeflate.t b/cpan/IO-Compress/t/100generic-rawdeflate.t new file mode 100644 index 0000000000..b5a43697bd --- /dev/null +++ b/cpan/IO-Compress/t/100generic-rawdeflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/100generic-zip.t b/cpan/IO-Compress/t/100generic-zip.t new file mode 100644 index 0000000000..907dada4c5 --- /dev/null +++ b/cpan/IO-Compress/t/100generic-zip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/101truncate-bzip2.t b/cpan/IO-Compress/t/101truncate-bzip2.t new file mode 100644 index 0000000000..7aba01dd39 --- /dev/null +++ b/cpan/IO-Compress/t/101truncate-bzip2.t @@ -0,0 +1,37 @@ +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/cpan/IO-Compress/t/101truncate-deflate.t b/cpan/IO-Compress/t/101truncate-deflate.t new file mode 100644 index 0000000000..2ae2b312df --- /dev/null +++ b/cpan/IO-Compress/t/101truncate-deflate.t @@ -0,0 +1,37 @@ +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/cpan/IO-Compress/t/101truncate-gzip.t b/cpan/IO-Compress/t/101truncate-gzip.t new file mode 100644 index 0000000000..1e546b47e9 --- /dev/null +++ b/cpan/IO-Compress/t/101truncate-gzip.t @@ -0,0 +1,36 @@ +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/cpan/IO-Compress/t/101truncate-rawdeflate.t b/cpan/IO-Compress/t/101truncate-rawdeflate.t new file mode 100644 index 0000000000..d81b54a7b3 --- /dev/null +++ b/cpan/IO-Compress/t/101truncate-rawdeflate.t @@ -0,0 +1,130 @@ +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/cpan/IO-Compress/t/101truncate-zip.t b/cpan/IO-Compress/t/101truncate-zip.t new file mode 100644 index 0000000000..0bc2c100d0 --- /dev/null +++ b/cpan/IO-Compress/t/101truncate-zip.t @@ -0,0 +1,38 @@ +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/cpan/IO-Compress/t/102tied-bzip2.t b/cpan/IO-Compress/t/102tied-bzip2.t new file mode 100644 index 0000000000..8503e02529 --- /dev/null +++ b/cpan/IO-Compress/t/102tied-bzip2.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/102tied-deflate.t b/cpan/IO-Compress/t/102tied-deflate.t new file mode 100644 index 0000000000..8747aee90f --- /dev/null +++ b/cpan/IO-Compress/t/102tied-deflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/102tied-gzip.t b/cpan/IO-Compress/t/102tied-gzip.t new file mode 100644 index 0000000000..52a502ecd3 --- /dev/null +++ b/cpan/IO-Compress/t/102tied-gzip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/102tied-rawdeflate.t b/cpan/IO-Compress/t/102tied-rawdeflate.t new file mode 100644 index 0000000000..f3ba80cfc8 --- /dev/null +++ b/cpan/IO-Compress/t/102tied-rawdeflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/102tied-zip.t b/cpan/IO-Compress/t/102tied-zip.t new file mode 100644 index 0000000000..04be98dc6f --- /dev/null +++ b/cpan/IO-Compress/t/102tied-zip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/103newtied-bzip2.t b/cpan/IO-Compress/t/103newtied-bzip2.t new file mode 100644 index 0000000000..ecf8a49893 --- /dev/null +++ b/cpan/IO-Compress/t/103newtied-bzip2.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/103newtied-deflate.t b/cpan/IO-Compress/t/103newtied-deflate.t new file mode 100644 index 0000000000..42a3d3c2bd --- /dev/null +++ b/cpan/IO-Compress/t/103newtied-deflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/103newtied-gzip.t b/cpan/IO-Compress/t/103newtied-gzip.t new file mode 100644 index 0000000000..7a453fa479 --- /dev/null +++ b/cpan/IO-Compress/t/103newtied-gzip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/103newtied-rawdeflate.t b/cpan/IO-Compress/t/103newtied-rawdeflate.t new file mode 100644 index 0000000000..93a5118526 --- /dev/null +++ b/cpan/IO-Compress/t/103newtied-rawdeflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/103newtied-zip.t b/cpan/IO-Compress/t/103newtied-zip.t new file mode 100644 index 0000000000..84b19453b7 --- /dev/null +++ b/cpan/IO-Compress/t/103newtied-zip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/104destroy-bzip2.t b/cpan/IO-Compress/t/104destroy-bzip2.t new file mode 100644 index 0000000000..e8c02cf3d2 --- /dev/null +++ b/cpan/IO-Compress/t/104destroy-bzip2.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/104destroy-deflate.t b/cpan/IO-Compress/t/104destroy-deflate.t new file mode 100644 index 0000000000..37511f7df4 --- /dev/null +++ b/cpan/IO-Compress/t/104destroy-deflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/104destroy-gzip.t b/cpan/IO-Compress/t/104destroy-gzip.t new file mode 100644 index 0000000000..5f686f480c --- /dev/null +++ b/cpan/IO-Compress/t/104destroy-gzip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/104destroy-rawdeflate.t b/cpan/IO-Compress/t/104destroy-rawdeflate.t new file mode 100644 index 0000000000..1463000e23 --- /dev/null +++ b/cpan/IO-Compress/t/104destroy-rawdeflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/104destroy-zip.t b/cpan/IO-Compress/t/104destroy-zip.t new file mode 100644 index 0000000000..d071a06d37 --- /dev/null +++ b/cpan/IO-Compress/t/104destroy-zip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/105oneshot-bzip2.t b/cpan/IO-Compress/t/105oneshot-bzip2.t new file mode 100644 index 0000000000..c402829fe4 --- /dev/null +++ b/cpan/IO-Compress/t/105oneshot-bzip2.t @@ -0,0 +1,22 @@ +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/cpan/IO-Compress/t/105oneshot-deflate.t b/cpan/IO-Compress/t/105oneshot-deflate.t new file mode 100644 index 0000000000..ab108eaa78 --- /dev/null +++ b/cpan/IO-Compress/t/105oneshot-deflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/105oneshot-gzip-only.t b/cpan/IO-Compress/t/105oneshot-gzip-only.t new file mode 100644 index 0000000000..0382df8e33 --- /dev/null +++ b/cpan/IO-Compress/t/105oneshot-gzip-only.t @@ -0,0 +1,134 @@ +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/cpan/IO-Compress/t/105oneshot-gzip.t b/cpan/IO-Compress/t/105oneshot-gzip.t new file mode 100644 index 0000000000..9a45222dc1 --- /dev/null +++ b/cpan/IO-Compress/t/105oneshot-gzip.t @@ -0,0 +1,22 @@ +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/cpan/IO-Compress/t/105oneshot-rawdeflate.t b/cpan/IO-Compress/t/105oneshot-rawdeflate.t new file mode 100644 index 0000000000..50cb80a3c1 --- /dev/null +++ b/cpan/IO-Compress/t/105oneshot-rawdeflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/105oneshot-zip-bzip2-only.t b/cpan/IO-Compress/t/105oneshot-zip-bzip2-only.t new file mode 100644 index 0000000000..f21e918b87 --- /dev/null +++ b/cpan/IO-Compress/t/105oneshot-zip-bzip2-only.t @@ -0,0 +1,168 @@ +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/cpan/IO-Compress/t/105oneshot-zip-only.t b/cpan/IO-Compress/t/105oneshot-zip-only.t new file mode 100644 index 0000000000..0906bf6e16 --- /dev/null +++ b/cpan/IO-Compress/t/105oneshot-zip-only.t @@ -0,0 +1,237 @@ +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/cpan/IO-Compress/t/105oneshot-zip.t b/cpan/IO-Compress/t/105oneshot-zip.t new file mode 100644 index 0000000000..e236fc66fa --- /dev/null +++ b/cpan/IO-Compress/t/105oneshot-zip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/106prime-bzip2.t b/cpan/IO-Compress/t/106prime-bzip2.t new file mode 100644 index 0000000000..d5a0d98fff --- /dev/null +++ b/cpan/IO-Compress/t/106prime-bzip2.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/106prime-deflate.t b/cpan/IO-Compress/t/106prime-deflate.t new file mode 100644 index 0000000000..0ef9bd8834 --- /dev/null +++ b/cpan/IO-Compress/t/106prime-deflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/106prime-gzip.t b/cpan/IO-Compress/t/106prime-gzip.t new file mode 100644 index 0000000000..b6ab10e6d2 --- /dev/null +++ b/cpan/IO-Compress/t/106prime-gzip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/106prime-rawdeflate.t b/cpan/IO-Compress/t/106prime-rawdeflate.t new file mode 100644 index 0000000000..4c81f7c605 --- /dev/null +++ b/cpan/IO-Compress/t/106prime-rawdeflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/106prime-zip.t b/cpan/IO-Compress/t/106prime-zip.t new file mode 100644 index 0000000000..702c40128a --- /dev/null +++ b/cpan/IO-Compress/t/106prime-zip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/107multi-bzip2.t b/cpan/IO-Compress/t/107multi-bzip2.t new file mode 100644 index 0000000000..0e7f5dbef3 --- /dev/null +++ b/cpan/IO-Compress/t/107multi-bzip2.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/107multi-deflate.t b/cpan/IO-Compress/t/107multi-deflate.t new file mode 100644 index 0000000000..397869bc92 --- /dev/null +++ b/cpan/IO-Compress/t/107multi-deflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/107multi-gzip.t b/cpan/IO-Compress/t/107multi-gzip.t new file mode 100644 index 0000000000..10922ed0da --- /dev/null +++ b/cpan/IO-Compress/t/107multi-gzip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/107multi-rawdeflate.t b/cpan/IO-Compress/t/107multi-rawdeflate.t new file mode 100644 index 0000000000..374cb67831 --- /dev/null +++ b/cpan/IO-Compress/t/107multi-rawdeflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/107multi-zip.t b/cpan/IO-Compress/t/107multi-zip.t new file mode 100644 index 0000000000..fea653fbf6 --- /dev/null +++ b/cpan/IO-Compress/t/107multi-zip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/108anyunc-bzip2.t b/cpan/IO-Compress/t/108anyunc-bzip2.t new file mode 100644 index 0000000000..4b981e6806 --- /dev/null +++ b/cpan/IO-Compress/t/108anyunc-bzip2.t @@ -0,0 +1,29 @@ +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/cpan/IO-Compress/t/108anyunc-deflate.t b/cpan/IO-Compress/t/108anyunc-deflate.t new file mode 100644 index 0000000000..ed5e6b5efe --- /dev/null +++ b/cpan/IO-Compress/t/108anyunc-deflate.t @@ -0,0 +1,29 @@ +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/cpan/IO-Compress/t/108anyunc-gzip.t b/cpan/IO-Compress/t/108anyunc-gzip.t new file mode 100644 index 0000000000..bac6a6a9d0 --- /dev/null +++ b/cpan/IO-Compress/t/108anyunc-gzip.t @@ -0,0 +1,29 @@ +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/cpan/IO-Compress/t/108anyunc-rawdeflate.t b/cpan/IO-Compress/t/108anyunc-rawdeflate.t new file mode 100644 index 0000000000..7d85dada9a --- /dev/null +++ b/cpan/IO-Compress/t/108anyunc-rawdeflate.t @@ -0,0 +1,29 @@ +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/cpan/IO-Compress/t/108anyunc-transparent.t b/cpan/IO-Compress/t/108anyunc-transparent.t new file mode 100644 index 0000000000..687b1f5cd2 --- /dev/null +++ b/cpan/IO-Compress/t/108anyunc-transparent.t @@ -0,0 +1,72 @@ +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/cpan/IO-Compress/t/108anyunc-zip.t b/cpan/IO-Compress/t/108anyunc-zip.t new file mode 100644 index 0000000000..72e015a6a1 --- /dev/null +++ b/cpan/IO-Compress/t/108anyunc-zip.t @@ -0,0 +1,29 @@ +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/cpan/IO-Compress/t/109merge-deflate.t b/cpan/IO-Compress/t/109merge-deflate.t new file mode 100644 index 0000000000..a489f354d3 --- /dev/null +++ b/cpan/IO-Compress/t/109merge-deflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/109merge-gzip.t b/cpan/IO-Compress/t/109merge-gzip.t new file mode 100644 index 0000000000..3041a99420 --- /dev/null +++ b/cpan/IO-Compress/t/109merge-gzip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/109merge-rawdeflate.t b/cpan/IO-Compress/t/109merge-rawdeflate.t new file mode 100644 index 0000000000..2c9663726e --- /dev/null +++ b/cpan/IO-Compress/t/109merge-rawdeflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/109merge-zip.t b/cpan/IO-Compress/t/109merge-zip.t new file mode 100644 index 0000000000..74adf09bf9 --- /dev/null +++ b/cpan/IO-Compress/t/109merge-zip.t @@ -0,0 +1,24 @@ +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/cpan/IO-Compress/t/110encode-bzip2.t b/cpan/IO-Compress/t/110encode-bzip2.t new file mode 100644 index 0000000000..974dc8f24a --- /dev/null +++ b/cpan/IO-Compress/t/110encode-bzip2.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/110encode-deflate.t b/cpan/IO-Compress/t/110encode-deflate.t new file mode 100644 index 0000000000..a1f93a9512 --- /dev/null +++ b/cpan/IO-Compress/t/110encode-deflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/110encode-gzip.t b/cpan/IO-Compress/t/110encode-gzip.t new file mode 100644 index 0000000000..d40c36e905 --- /dev/null +++ b/cpan/IO-Compress/t/110encode-gzip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/110encode-rawdeflate.t b/cpan/IO-Compress/t/110encode-rawdeflate.t new file mode 100644 index 0000000000..58fa7417b1 --- /dev/null +++ b/cpan/IO-Compress/t/110encode-rawdeflate.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/110encode-zip.t b/cpan/IO-Compress/t/110encode-zip.t new file mode 100644 index 0000000000..80e99eec58 --- /dev/null +++ b/cpan/IO-Compress/t/110encode-zip.t @@ -0,0 +1,21 @@ +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/cpan/IO-Compress/t/999pod.t b/cpan/IO-Compress/t/999pod.t new file mode 100644 index 0000000000..760f737716 --- /dev/null +++ b/cpan/IO-Compress/t/999pod.t @@ -0,0 +1,16 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use Test::More; + +eval "use Test::Pod 1.00"; + +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +all_pod_files_ok(); + diff --git a/cpan/IO-Compress/t/compress/CompTestUtils.pm b/cpan/IO-Compress/t/compress/CompTestUtils.pm new file mode 100644 index 0000000000..cb63d6274c --- /dev/null +++ b/cpan/IO-Compress/t/compress/CompTestUtils.pm @@ -0,0 +1,684 @@ +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/cpan/IO-Compress/t/compress/any.pl b/cpan/IO-Compress/t/compress/any.pl new file mode 100644 index 0000000000..d95766b0a9 --- /dev/null +++ b/cpan/IO-Compress/t/compress/any.pl @@ -0,0 +1,98 @@ + +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/cpan/IO-Compress/t/compress/anyunc.pl b/cpan/IO-Compress/t/compress/anyunc.pl new file mode 100644 index 0000000000..2860e2571c --- /dev/null +++ b/cpan/IO-Compress/t/compress/anyunc.pl @@ -0,0 +1,93 @@ + +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/cpan/IO-Compress/t/compress/destroy.pl b/cpan/IO-Compress/t/compress/destroy.pl new file mode 100644 index 0000000000..186520df16 --- /dev/null +++ b/cpan/IO-Compress/t/compress/destroy.pl @@ -0,0 +1,115 @@ + +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/cpan/IO-Compress/t/compress/encode.pl b/cpan/IO-Compress/t/compress/encode.pl new file mode 100644 index 0000000000..142bd08e59 --- /dev/null +++ b/cpan/IO-Compress/t/compress/encode.pl @@ -0,0 +1,123 @@ + +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/cpan/IO-Compress/t/compress/generic.pl b/cpan/IO-Compress/t/compress/generic.pl new file mode 100644 index 0000000000..54abab0a54 --- /dev/null +++ b/cpan/IO-Compress/t/compress/generic.pl @@ -0,0 +1,1590 @@ + +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/cpan/IO-Compress/t/compress/merge.pl b/cpan/IO-Compress/t/compress/merge.pl new file mode 100644 index 0000000000..6134292466 --- /dev/null +++ b/cpan/IO-Compress/t/compress/merge.pl @@ -0,0 +1,322 @@ +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/cpan/IO-Compress/t/compress/multi.pl b/cpan/IO-Compress/t/compress/multi.pl new file mode 100644 index 0000000000..3e9bbfd464 --- /dev/null +++ b/cpan/IO-Compress/t/compress/multi.pl @@ -0,0 +1,261 @@ + +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/cpan/IO-Compress/t/compress/newtied.pl b/cpan/IO-Compress/t/compress/newtied.pl new file mode 100644 index 0000000000..41861e9072 --- /dev/null +++ b/cpan/IO-Compress/t/compress/newtied.pl @@ -0,0 +1,374 @@ +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/cpan/IO-Compress/t/compress/oneshot.pl b/cpan/IO-Compress/t/compress/oneshot.pl new file mode 100644 index 0000000000..9c76cefdb5 --- /dev/null +++ b/cpan/IO-Compress/t/compress/oneshot.pl @@ -0,0 +1,1592 @@ +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/cpan/IO-Compress/t/compress/prime.pl b/cpan/IO-Compress/t/compress/prime.pl new file mode 100644 index 0000000000..4e804e5b00 --- /dev/null +++ b/cpan/IO-Compress/t/compress/prime.pl @@ -0,0 +1,90 @@ + +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/cpan/IO-Compress/t/compress/tied.pl b/cpan/IO-Compress/t/compress/tied.pl new file mode 100644 index 0000000000..80d42b7561 --- /dev/null +++ b/cpan/IO-Compress/t/compress/tied.pl @@ -0,0 +1,492 @@ + +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/cpan/IO-Compress/t/compress/truncate.pl b/cpan/IO-Compress/t/compress/truncate.pl new file mode 100644 index 0000000000..b362fd3b6e --- /dev/null +++ b/cpan/IO-Compress/t/compress/truncate.pl @@ -0,0 +1,169 @@ + +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/cpan/IO-Compress/t/compress/zlib-generic.pl b/cpan/IO-Compress/t/compress/zlib-generic.pl new file mode 100644 index 0000000000..94e5da9f72 --- /dev/null +++ b/cpan/IO-Compress/t/compress/zlib-generic.pl @@ -0,0 +1,233 @@ + +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/cpan/IO-Compress/t/cz-01version.t b/cpan/IO-Compress/t/cz-01version.t new file mode 100644 index 0000000000..9d6f283a52 --- /dev/null +++ b/cpan/IO-Compress/t/cz-01version.t @@ -0,0 +1,42 @@ +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/cpan/IO-Compress/t/cz-05examples.t b/cpan/IO-Compress/t/cz-05examples.t new file mode 100644 index 0000000000..5a8fb33e20 --- /dev/null +++ b/cpan/IO-Compress/t/cz-05examples.t @@ -0,0 +1,163 @@ +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/cpan/IO-Compress/t/cz-06gzsetp.t b/cpan/IO-Compress/t/cz-06gzsetp.t new file mode 100644 index 0000000000..0f8d83d5ac --- /dev/null +++ b/cpan/IO-Compress/t/cz-06gzsetp.t @@ -0,0 +1,139 @@ +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/cpan/IO-Compress/t/cz-08encoding.t b/cpan/IO-Compress/t/cz-08encoding.t new file mode 100644 index 0000000000..f377609e57 --- /dev/null +++ b/cpan/IO-Compress/t/cz-08encoding.t @@ -0,0 +1,139 @@ +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/cpan/IO-Compress/t/cz-14gzopen.t b/cpan/IO-Compress/t/cz-14gzopen.t new file mode 100644 index 0000000000..e876143b29 --- /dev/null +++ b/cpan/IO-Compress/t/cz-14gzopen.t @@ -0,0 +1,646 @@ +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/cpan/IO-Compress/t/globmapper.t b/cpan/IO-Compress/t/globmapper.t new file mode 100644 index 0000000000..10a4d88716 --- /dev/null +++ b/cpan/IO-Compress/t/globmapper.t @@ -0,0 +1,304 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict ; +use warnings ; + +use Test::More ; +use CompTestUtils; + + +BEGIN +{ + plan(skip_all => "File::GlobMapper needs Perl 5.005 or better - you have +Perl $]" ) + if $] < 5.005 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 68 + $extra ; + + use_ok('File::GlobMapper') ; +} + +{ + title "Error Cases" ; + + my $gm; + + for my $delim ( qw/ ( ) { } [ ] / ) + { + $gm = new File::GlobMapper("${delim}abc", '*.X'); + ok ! $gm, " new failed" ; + is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", + " catch unmatched $delim"; + } + + for my $delim ( qw/ ( ) [ ] / ) + { + $gm = new File::GlobMapper("{${delim}abc}", '*.X'); + ok ! $gm, " new failed" ; + is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", + " catch unmatched $delim inside {}"; + } + + +} + +{ + title "input glob matches zero files"; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + + my $gm = new File::GlobMapper("$tmpDir/Z*", '*.X'); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 0, " returned 0 maps"; + is_deeply $map, [], " zero maps" ; + + my $hash = $gm->getHash() ; + is_deeply $hash, {}, " zero maps" ; +} + +{ + title 'test wildcard mapping of * in destination'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/ab*.tmp", "*X"); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmpX)], + [map { "$tmpDir/$_" } qw(abc2.tmp abc2.tmpX)], + [map { "$tmpDir/$_" } qw(abc3.tmp abc3.tmpX)], + ], " got mapping"; + + my $hash = $gm->getHash() ; + is_deeply $hash, + { map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmpX + abc2.tmp abc2.tmpX + abc3.tmp abc3.tmpX), + }, " got mapping"; +} + +{ + title 'no wildcards in input or destination'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/abc2.tmp", "$tmpDir/abc2.tmp"); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 1, " returned 1 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_.tmp" } qw(abc2 abc2)], + ], " got mapping"; + + my $hash = $gm->getHash() ; + is_deeply $hash, + { map { "$tmpDir/$_.tmp" } qw(abc2 abc2), + }, " got mapping"; +} + +{ + title 'test wildcard mapping of {} in destination'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "*.X"); + #diag "Input pattern is $gm->{InputPattern}"; + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 2, " returned 2 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmp.X)], + [map { "$tmpDir/$_" } qw(abc3.tmp abc3.tmp.X)], + ], " got mapping"; + + $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "$tmpDir/X.#1.X") + or diag $File::GlobMapper::Error ; + #diag "Input pattern is $gm->{InputPattern}"; + ok $gm, " created GlobMapper object" ; + + $map = $gm->getFileMap() ; + is @{ $map }, 2, " returned 2 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X.1.X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X.3.X)], + ], " got mapping"; + +} + + +{ + title 'test wildcard mapping of multiple * to #'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/*b(*).tmp", "$tmpDir/X-#2-#1-X"); + ok $gm, " created GlobMapper object" + or diag $File::GlobMapper::Error ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], + [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], + ], " got mapping"; +} + +{ + title 'test wildcard mapping of multiple ? to #'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("$tmpDir/?b(*).tmp", "$tmpDir/X-#2-#1-X"); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], + [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], + ], " got mapping"; +} + +{ + title 'test wildcard mapping of multiple ?,* and [] to #'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $gm = new File::GlobMapper("./$tmpDir/?b[a-z]*.tmp", "./$tmpDir/X-#3-#2-#1-X"); + ok $gm, " created GlobMapper object" ; + + #diag "Input pattern is $gm->{InputPattern}"; + my $map = $gm->getFileMap() ; + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "./$tmpDir/$_" } qw(abc1.tmp X-1-c-a-X)], + [map { "./$tmpDir/$_" } qw(abc2.tmp X-2-c-a-X)], + [map { "./$tmpDir/$_" } qw(abc3.tmp X-3-c-a-X)], + ], " got mapping"; +} + +{ + title 'input glob matches a file multiple times'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch "$tmpDir/abc.tmp"; + + my $gm = new File::GlobMapper("$tmpDir/{a*,*c}.tmp", '*.X'); + ok $gm, " created GlobMapper object" ; + + my $map = $gm->getFileMap() ; + is @{ $map }, 1, " returned 1 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc.tmp abc.tmp.X)], ], " got mapping"; + + my $hash = $gm->getHash() ; + is_deeply $hash, + { map { "$tmpDir/$_" } qw(abc.tmp abc.tmp.X) }, " got mapping"; + +} + +{ + title 'multiple input files map to one output file'; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc def) ; + + my $gm = new File::GlobMapper("$tmpDir/*.tmp", "$tmpDir/fred"); + ok ! $gm, " did not create GlobMapper object" ; + + is $File::GlobMapper::Error, 'multiple input files map to one output file', " Error is expected" ; + + #my $map = $gm->getFileMap() ; + #is @{ $map }, 1, " returned 1 maps"; + #is_deeply $map, + #[ [map { "$tmpDir/$_" } qw(abc1 abc.X)], ], " got mapping"; +} + +{ + title "globmap" ; + + my $tmpDir = 'td'; + my $lex = new LexDir $tmpDir; + mkdir $tmpDir, 0777 ; + + touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; + + my $map = File::GlobMapper::globmap("$tmpDir/*b*.tmp", "$tmpDir/X-#2-#1-X"); + ok $map, " got map" + or diag $File::GlobMapper::Error ; + + is @{ $map }, 3, " returned 3 maps"; + is_deeply $map, + [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], + [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], + [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], + ], " got mapping"; +} + +# TODO +# test each of the wildcard metacharacters can be mapped to the output filename +# +# ~ [] {} . * + +# input & output glob with no wildcards is ok +# input with no wild or output with no wild is bad +# input wild has concatenated *'s +# empty string for either both from & to +# escaped chars within [] and {}, including the chars []{} +# escaped , within {} +# missing ] and missing } +# {} and {,} are special cases +# {ab*,de*} +# {abc,{},{de,f}} => abc {} de f + |