diff options
| author | Nicholas Clark <nick@ccl4.org> | 2009-10-02 18:12:44 +0100 |
|---|---|---|
| committer | Nicholas Clark <nick@ccl4.org> | 2009-10-02 18:12:44 +0100 |
| commit | 8b88b2b2a83b118e358c4d04557659e32d47c01b (patch) | |
| tree | c696c6c5c77b90417d6640dc151bca8bd3596dc2 /ext | |
| parent | 43aed010bf8b6e3fe32d5f9e8e086dda22b5b4c6 (diff) | |
| download | perl-8b88b2b2a83b118e358c4d04557659e32d47c01b.tar.gz | |
Move Storable from ext/ to dist/
Diffstat (limited to 'ext')
49 files changed, 0 insertions, 14224 deletions
diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog deleted file mode 100644 index ea3995324a..0000000000 --- a/ext/Storable/ChangeLog +++ /dev/null @@ -1,753 +0,0 @@ -Mon May 18 09:38:20 IST 2009 Abhijit Menon-Sen <ams@toroid.org> - - Version 2.20 - - Fix bug handling blessed references to overloaded objects, plus - other miscellaneous fixes. - - (Version 2.19 was released with 5.8.9.) - -Thu Nov 22 13:24:18 IST 2007 Abhijit Menon-Sen <ams@toroid.org> - - Version 2.18 - - Compile fixes for older Perls. (No functional changes.) - -Sat Nov 17 02:12:12 IST 2007 Abhijit Menon-Sen <ams@toroid.org> - - Version 2.17 - - Various broken tests fixed. (No functional changes.) - -Sat Mar 31 06:11:06 IST 2007 Abhijit Menon-Sen <ams@toroid.org> - - Version 2.16 - - 1. Fixes to Storable::dclone, read_magic, retrieve_lscalar - 2. Storable 0.1 compatibility - 3. Miscellaneous compile/leak/test/portability fixes - -Mon May 23 22:48:49 IST 2005 Abhijit Menon-Sen <ams@wiw.org> - - Version 2.15 - - Minor changes to address a couple of compile problems. - -Mon Apr 25 07:29:14 IST 2005 Abhijit Menon-Sen <ams@wiw.org> - - Version 2.14 - - 1. Store weak references - 2. Add STORABLE_attach hook. - -Thu Jun 17 12:26:43 BST 2004 Nicholas Clark <nick@ccl4.org> - - Version 2.13 - - 1. Don't change the type of top level overloaded references to RV - - they are perfectly correct as PVMG - 2. Storable needs to cope with incoming frozen data that happens to be - utf8 encoded. - -Wed Mar 17 15:40:29 GMT 2004 Nicholas Clark <nick@ccl4.org> - - Version 2.12 - - 1. Add regression tests for the auto-require of STORABLE_thaw - 2. Add auto-require of modules to restore overloading (and tests) - 3. Change to no context (should give speedup with ithreads) - -Sat Mar 13 20:11:03 GMT 2004 Nicholas Clark <nick@ccl4.org> - - Version 2.11 - - 1. Storing restricted hashes in canonical order would SEGV. Fixed. - 2. It was impossible to retrieve references to PL_sv_no and and - PL_sv_undef from STORABLE_thaw hooks. - 3. restrict.t was failing on 5.8.0, due to 5.8.0's unique - implementation of restricted hashes using PL_sv_undef - 4. These changes allow a space optimisation for restricted hashes. - -Sat Jan 24 16:22:32 IST 2004 Abhijit Menon-Sen <ams@wiw.org> - - Version 2.10 - - 1. Thread safety: Storable::CLONE/init_perlinterp() now create - a new Perl context for each new ithread. - (From Stas Bekman and Jan Dubois.) - 2. Fix a tag count mismatch with $Storable::Deparse that caused - all back-references after a stored sub to be off-by-N (where - N was the number of code references in between). - (From Sam Vilain.) - 3. Prevent CODE references from turning into SCALAR references. - (From Slaven Rezic.) - -Sat Jan 3 18:49:18 GMT 2004 Nicholas Clark <nick@ccl4.org> - - Version 2.09 - - Fix minor problems with the CPAN release - 1: Make Storable.xs work on 5.8.2 and later (already in the core) - 2: Ship the linux hints file - 3: Ship Test::More for the benefit of Perls pre 5.6.2 - 4: Correct Makefile.PL to only install in core for 5.8.0 and later - -Sat Sep 6 01:08:20 IST 2003 Abhijit Menon-Sen <ams@wiw.org> - - Version 2.08 - - This release works around a 5.8.0 bug which caused hashes to not - be marked as having key flags even though an HEK had HEK_WASUTF8 - set. (Note that the only reasonable solution is to silently drop - the flag from the affected key.) - - Users of RT 3 who were seeing assertion failures should upgrade. - (Perl 5.8.1 will have the bug fixed.) - -Mon May 5 10:24:16 IST 2003 Abhijit Menon-Sen <ams@wiw.org> - - Version 2.07 - - Minor bugfixes (self-tied objects are now correctly stored, as - are the results of additions larger than INT_MAX). - -Mon Oct 7 21:56:38 BST 2002 Nicholas Clark <nick@ccl4.org> - - Version 2.06 - - Remove qr// from t/downgrade.t so that it will run on 5.004 - Mention $File::Spec::VERSION a second time in t/forgive.t so that it - runs without warnings in 5.004 (this may be a 5.00405 bug I'm working - round) - Fix t/integer.t initialisation to actually generate 64 bits of 9c - Fix comparison tests to use eval to get around 64 bit IV conversion - issues on 5.6.x, following my t/integer.t ^ precedence bug found by - Rafael Garcia-Suarez - Alter t/malice.t to work with Test/More.pm in t/, and skip individual - subtests that use $Config{ptrsize}, so that the rest of the test can - now be run with 5.004 - Change t/malice.t and the error message in check_magic in Storable.xs - from "Pointer integer size" to "Pointer size" - Remove prerequisite of Test::More from Makefile.PL - Ship Test::Builder, Test::Simple and Test::More in t - -Thu Oct 3 08:57:22 IST 2002 Abhijit Menon-Sen <ams@wiw.org> - - Version 2.05 - - Adds support for CODE references from Slaven Rezic - <slaven.rezic@berlin.de>. - -Fri Jun 7 23:55:41 BST 2002 Nicholas Clark - - Version 2.04 - - Bug fix from Radu Greab <radu@netsoft.ro> (plus regression test) - to fix a recently introduced bug detected by Dave Rolsky. - Bug was that for a non threaded build, the class information was - being lost at freeze time on the first object with a STORABLE_freeze - hook. Consequentially the object was not blessed at all when thawed. - (The presence (or lack) of STORABLE_thaw was irrelevant; this was - a store-time data lost bug, caused by failure to initialize internal - context) - The bug was introduced as development perl change 16442 (on - 2002/05/07), so has been present since 2.00. - Patches to introduce more regression tests to reduce the chance of - a reoccurance of this sort of goof are always welcome. - -Thu May 30 20:31:08 BST 2002 Nicholas Clark <nick@ccl4.org> - - Version 2.03 Header changes on 5.6.x on Unix where IV is long long - - 5.6.x introduced the ability to have IVs as long long. However, - Configure still defined BYTEORDER based on the size of a long. - Storable uses the BYTEORDER value as part of the header, but - doesn't explicity store sizeof(IV) anywhere in the header. - Hence on 5.6.x built with IV as long long on a platform that - uses Configure (ie most things except VMS and Windows) headers - are identical for the different IV sizes, despite the files - containing some fields based on sizeof(IV) - - 5.8.0 is consistent; all platforms have BYTEORDER in config.h - based on sizeof(IV) rather than sizeof(long). This means that - the value of BYTEORDER will change from (say) 4321 to 87654321 - between 5.6.1 and 5.8.0 built with the same options to Configure - on the same machine. This means that the Storable header will - differ, and the two versions will wrongly thing that they are - incompatible. - - For the benefit of long term consistency, Storable now - implements the 5.8.0 BYTEORDER policy on 5.6.x. This means that - 2.03 onwards default to be incompatible with 2.02 and earlier - (ie the large 1.0.x installed base) on the same 5.6.x perl. - - To allow interworking, a new variable - $Storable::interwork_56_64bit is introduced. It defaults to - false. Set it to true to read and write old format files. Don't - use it unless you have existing stored data written with 5.6.x - that you couldn't otherwise read, or you need to interwork with - a machine running older Storable on a 5.6.x with long long IVs - (i.e., you probably don't need to use it). - -Sat May 25 22:38:39 BST 2002 Nicholas Clark <nick@ccl4.org> - - Version 2.02 - - Rewrite Storable.xs so that the file header structure for write_magic - is built at compile time, and check_magic attempts to the header in - blocks rather than byte per byte. These changes make the compiled - extension 2.25% smaller, but are not significant enough to give a - noticeable speed up. - -Thu May 23 22:50:41 BST 2002 Nicholas Clark <nick@ccl4.org> - - Version 2.01 - - - New regression tests integer.t - - Add code to safely store large unsigned integers. - - Change code not to attempt to store large integers (ie > 32 bits) - in network order as 32 bits. - - *Never* underestimate the value of a pathological test suite carefully - crafted with maximum malice before writing a line of real code. It - prevents crafty bugs from stowing away in your released code. - It's much less embarrassing to find them before you ship. - (Well, never underestimate it if you ever want to work for me) - -Fri May 17 22:48:59 BST 2002 Nicholas Clark <nick@ccl4.org> - - Version 2.0, binary format 2.5 (but writes format 2.4 on pre 5.7.3) - - The perl5 porters have decided to make sure that Storable still - builds on pre-5.8 perls, and make the 5.8 version available on CPAN. - The VERSION is now 2.0, and it passes all tests on 5.005_03, 5.6.1 - and 5.6.1 with threads. On 5.6.0 t/downgrade.t fails tests 34 and 37, - due to a bug in 5.6.0 - upgrade to 5.6.1. - - Jarkko and I have collated the list of changes the perl5 porters have - from the perl5 Changes file: - - - data features of upcoming perl 5.8.0 are supported: Unicode hash - keys (Unicode hash values have been supported since Storable 1.0.1) - and "restricted hashes" (readonly hashes and hash entries) - - a newer version of perl can now be used to serialize data which is - not supported in earlier perls: Storable will attempt to do the - right thing for as long as possible, croaking only when safe data - conversion simply isn't possible. Alternatively earlier perls can - opt to have a lossy downgrade data instead of croaking - - when built with perls pre 5.7.3 this Storable writes out files - with binary format 2.4, the same format as Storable 1.0.8 onwards. - This should mean that this Storable will inter-operate seamlessly - with any Storable 1.0.8 or newer on perls pre 5.7.3 - - dclone() now works with empty string scalar objects - - retrieving of large hashes is now more efficient - - more routines autosplit out of the main module, so Storable should - load slightly more quickly - - better documentation - - the internal context objects are now freed explicitly, rather than - relying on thread or process exit - - bugs fixed in debugging trace code affecting builds made with 64 bit - IVs - - code tidy-ups to allow clean compiles with more warning options - turned on avoid problems with $@ getting corrupted on 5.005_03 if - Carp wasn't already loaded - - added &show_file_magic, so you can add to /etc/magic and teach - Unix's file command about Storable files - - We plan to keep Storable on CPAN in sync with the Perl core, so - if you encounter bugs or other problems building or using Storable, - please let us know at perl5-porters@perl.org - Patches welcome! - -Sat Dec 1 14:37:54 MET 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - This is the LAST maintenance release of the Storable module. - Indeed, Storable is now part of perl 5.8, and will be maintained - as part of Perl. The CPAN module will remain available there - for people running pre-5.8 perls. - - Avoid requiring Fcntl upfront, useful to embedded runtimes. - Use an eval {} for testing, instead of making Storable.pm - simply fail its compilation in the BEGIN block. - - store_fd() will now correctly autoflush file if needed. - -Tue Aug 28 23:53:20 MEST 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Fixed truncation race with lock_retrieve() in lock_store(). - The file has to be truncated only once the exclusive lock is held. - - Removed spurious debugging messages in .xs file. - -Sun Jul 1 13:27:32 MEST 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Systematically use "=over 4" for POD linters. - Apparently, POD linters are much stricter than would - otherwise be needed, but that's OK. - - Fixed memory corruption on croaks during thaw(). Thanks - to Claudio Garcia for reproducing this bug and providing the - code to exercise it. Added test cases for this bug, adapted - from Claudio's code. - - Made code compile cleanly with -Wall (from Jarkko Hietaniemi). - - Changed tagnum and classnum from I32 to IV in context. Also - from Jarkko. - -Thu Mar 15 01:22:32 MET 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Last version was wrongly compiling with assertions on, due - to an edit glitch. That did not cause any problem (apart from - a slight performance loss) excepted on Win* platforms, where the - assertion code does not compile. - -Sat Feb 17 13:37:37 MET 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Version 1.0.10. - - Forgot to increase version number at previous patch (there were - two of them, which is why we jump from 1.0.8 to 1.0.10). - -Sat Feb 17 13:35:00 MET 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Version 1.0.8, binary format 2.4. - - Fixed incorrect error message. - - Now bless objects ASAP at retrieve time, which is meant to fix - two bugs: - - * Indirect references to overloaded object were not able to - restore overloading if the object was not blessed yet, - which was possible since blessing occurred only after the - recursive retrieval. - - * Storable hooks asking for serialization of blessed ref could - get un-blessed refs at retrieval time, for the very same - reason. - - The fix implemented here was suggested by Nick Ing-Simmons. - - Added support for blessed ref to tied structures. This is the - cause for the binary format change. - - Added EBCDIC version of the compatibility test with 0.6.11, - from Peter Prymmer - - Added tests for the new features, and to make sure the bugs they - are meant to fix are indeed fixed. - -Wed Jan 3 10:43:18 MET 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Removed spurious 'clean' entry in Makefile.PL. - - Added CAN_FLOCK to determine whether we can flock() or not, - by inspecting Perl's configuration parameters, as determined - by Configure. - - Trace offending package when overloading cannot be restored - on a scalar. - - Made context cleanup safer to avoid dup freeing, mostly in the - presence of repeated exceptions during store/retrieve (which can - cause memory leaks anyway, so it's just additional safety, not a - definite fix). - -Sun Nov 5 18:23:48 MET 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Version 1.0.6. - - Fixed severe "object lost" bug for STORABLE_freeze returns, - when refs to lexicals, taken within the hook, were to be - serialized by Storable. Enhanced the t/recurse.t test to - stress hook a little more with refs to lexicals. - -Thu Oct 26 19:14:38 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Version 1.0.5. - - Documented that store() and retrieve() can return undef. - That is, the error reporting is not always made via exceptions, - as the paragraph on error reporting was implying. - - Auto requires module of blessed ref when STORABLE_thaw misses. - When the Storable engine looks for the STORABLE_thaw hook and - does not find it, it now tries to require the package into which - the blessed reference is. - - Just check $^O, in t/lock.t: there's no need to pull the whole - Config module for that. - -Mon Oct 23 20:03:49 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Version 1.0.4. - - Protected calls to flock() for DOS platform: apparently, the - flock/fcnlt emulation is reported to be broken on that - platform. - - Added logcarp emulation if they don't have Log::Agent, since - we now use it to carp when lock_store/lock_retrieve is used - on DOS. - -Fri Sep 29 21:52:29 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Version 1.0.3. - - Avoid using "tainted" and "dirty" since Perl remaps them via - cpp (i.e. #define). This is deeply harmful when threading - is enabled. This concerned both the context structure and - local variable and argument names. Brrr..., scary! - -Thu Sep 28 23:46:39 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Version 1.0.2. - - Fixed spelling in README. - - Added lock_store, lock_nstore, and lock_retrieve (advisory locking) - after a proposal from Erik Haugan <erik@solbors.no>. - - Perls before 5.004_04 lack newSVpvn, added remapping in XS. - - Fixed stupid typo in the t/utf8.t test. - -Sun Sep 17 18:51:10 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Version 1.0.1, binary format 2.3. - - Documented that doubles are stored stringified by nstore(). - - Added Salvador Ortiz Garcia in CREDITS section, He identified - a bug in the store hooks and proposed the right fix: the class - id was allocated too soon. His bug case was also added to - the regression test suite. - - Now only taint retrieved data when source was tainted. A bug - discovered by Marc Lehmann. - - Added support for UTF-8 strings, a contribution of Marc Lehmann. - This is normally only activated in post-5.6 perls. - -Thu Aug 31 23:06:06 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - First official release Storable 1.0, for inclusion in perl 5.7.0. - The license scheme is now compatible with Perl's. - -Thu Aug 24 01:02:02 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - ANSI-fied most of the code, preparing for Perl core integration. - The next version of Storable will be 0.8, and will be integrated - into the Perl core (development branch). - - Dispatch tables were moved upfront to relieve some compilers, - especially on AIX and Windows platforms. - - Merged 64-bit fixes from perl5-porters. - -Mon Aug 14 09:22:04 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Added a refcnt dec in retrieve_tied_key(): sv_magic() increases - the refcnt on the mg_ptr as well. - - Removed spurious dependency to Devel::Peek, which was used for - testing only in t/tied_items.t. Thanks to Conrad Heiney - <conrad@fringehead.org> for spotting it first. - -Sun Aug 13 22:12:59 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Marc Lehmann kindly contributed code to add overloading support - and to handle references to tied variables. - - Rewrote leading blurb about compatibility to make it clearer what - "backward compatibility" is about: when I say 0.7 is backward - compatible with 0.6, it means the revision 0.7 can read files - produced by 0.6. - - Mention new Clone(3) extension in SEE ALSO. - - Was wrongly optimizing for "undef" values in hashes by not - fully recursing: as a result, tied "undef" values were incorrectly - serialized. - -Sun Jul 30 12:59:17 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - First revision of Storable 0.7. - - The serializing format is new, known as version 2.0. It is fully - backward compatible with 0.6. Earlier formats are deprecated and - have not even been tested: next version will drop pre-0.6 format. - - Changes since 0.6@11: - - - Moved interface to the "beta" status. Some tiny parts are still - subject to change, but nothing important enough to warrant an "alpha" - status any longer. - - - Slightly reduced the size of the Storable image by factorizing - object class names and removing final object storage notification due - to a redesign of the blessed object storing. - - - Classes can now redefine how they wish their instances to be serialized - and/or deep cloned. Serializing hooks are written in Perl code. - - - The engine is now fully re-entrant. - -Sun Apr 2 23:47:50 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Added provision to detect more recent binary formats, since - the new upcoming Storable-0.7 will use a different format. - In order to prevent attempting the de-serialization of newer - formats by older versions, I'm adding this now to the 0.6 series. - - I'm expecting this revision to be the last of the 0.6 series. - Unless it does not work with perl 5.6, which I don't use yet, - and therefore against which I cannot test. - -Wed Mar 29 19:55:21 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Added note about format incompatibilities with old versions - (i.e. pre 0.5@9 formats, which cannot be understood as there - was no versionning information in the file by then). - - Protect all $@ variables when eval {} used, to avoid corrupting - it when store/retrieve is called within an exception handler. - - Mistakenly included "patchlevel.h" instead of <patchlevel.h>, - preventing Perl's patchlevel from being included, which is - needed starting from 5.6. - -Tue May 12 09:15:15 METDST 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Fixed shared "undef" bug in hashes, which did not remain shared - through store/retrieve. - -Thu Feb 10 19:48:16 MET 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - added last_op_in_netorder() predicate - documented last_op_in_netorder() - added tests for the new last_op_in_netorder() predicate - -Wed Oct 20 19:07:36 MEST 1999 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Forgot to update VERSION - -Tue Oct 19 21:25:02 MEST 1999 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Added mention of japanese translation for the manual page. - - Fixed typo in macro that made threaded code not compilable, - especially on Win32 platforms. - - Changed detection of older perls (pre-5.005) by testing PATCHLEVEL - directly instead of relying on internal symbols. - -Tue Sep 14 22:13:28 MEST 1999 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - Integrated "thread-safe" patch from Murray Nesbitt. - Note that this may not be very efficient for threaded code, - see comment in the code. - - Try to avoid compilation warning on 64-bit CPUs. Can't test it, - since I don't have access to such machines. - -Mon Jul 12 14:37:19 METDST 1999 Raphael Manfredi <Raphael_Manfredi@pobox.com> - - changed my e-mail to pobox. - - mentionned it is not thread-safe. - - updated version number. - - uses new internal PL_* naming convention. - -Fri Jul 3 13:38:16 METDST 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Updated benchmark figures due to recent optimizations done in - store(): tagnums are now stored as-is in the hash table, so - no surrounding SV is created. And the "shared keys" mode for - hash table was turned off. - - Fixed backward compatibility (wrt 0.5@9) for retrieval of - blessed refs. That old version did something wrong, but the - bugfix prevented correct retrieval of the old format. - -Mon Jun 22 11:00:48 METDST 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Changed benchmark figures. - - Adjust refcnt of tied objects after calling sv_magic() to avoid - memory leaks. Contributed by Jeff Gresham. - -Fri Jun 12 11:50:04 METDST 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Added workaround for persistent LVALUE-ness in perl5.004. All - scalars tagged as being an lvalue are handled as if they were - not an lvalue at all. Added test for that LVALUE bug workaround. - - Now handles Perl immortal scalars explicitely, by storing &sv_yes - as such, explicitely. - - Retrieval of non-immortal undef cannot be shared. Previous - version was over-optimizing by not creating a separate SV for - all undefined scalars seen. - -Thu Jun 4 17:21:51 METDST 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Baseline for Storable-0.6@0. - - This version introduces a binary incompatibility in the generated - binary image, which is more compact than older ones by approximatively - 15%, depending on the exact degree of sharing in your structures. - - The good news is that your older images can still be retrieved with - this version, i.e. backward compatibility is preserved. This version - of Storable can only generate new binaries however. - - Another good news is that the retrieval of data structure is - significantly quicker than before, because a Perl array is used - instead of a hash table to keep track of retrieved objects, and - also because the image being smaller, less I/O function calls are - made. - -Tue May 12 09:15:15 METDST 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Version number now got from Storable.pm directly. - - Fixed overzealous sv_type() optimization, which would make - Storable fail when faced with an "upgraded" SV to the PVIV - or PVNV kind containing a reference. - -Thu Apr 30 15:11:30 METDST 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Extended the SYNOPSIS section to give quick overview of the - routines and their signature. - - Optimized sv_type() to avoid flags checking when not needed, i.e. - when their type makes it impossible for them to be refs or tied. - This slightly increases throughput by a few percents when refs - and tied variables are marginal occurrences in your data. - - Stubs for XS now use OutputStream and InputStream file types to - make it work when the given file is actually a socket. Perl - makes a distinction for sockets in its internal I/O structures - by having both a read and a write structure, whereas plain files - share the same one. - -Tue Jun 3 09:41:33 METDST 1997 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Thanks to a contribution from Benjamin A. Holzman, Storable is now - able to correctly serialize tied SVs, i.e. tied arrays, hashes - and scalars. - -Thu Apr 9 18:07:51 METDST 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - I said SvPOK() had changed to SvPOKp(), but that was a lie... - -Wed Apr 8 13:14:29 METDST 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Wrote sizeof(SV *) instead of sizeof(I32) when portable, which - in effect mangled the object tags and prevented portability - accross 32/64 bit architectures! - -Wed Mar 25 14:57:02 MET 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Added code example for store_fd() and retrieve_fd() in the - man page, to emphasize that file descriptors must be passed as - globs, not as plain strings. - - Cannot use SV addresses as tag when using nstore() on LP64. This - was the cause of problems when creating a storable image on an - LP64 machine and retrieving it on an ILP32 system, which is - exactly what nstore() is meant for... - - However, we continue to use SV addresses as tags for plain store(), - because benchamarking shows that it saves up to 8% of the store - time, and store() is meant to be fast at the expense of lack - of portability. - - This means there will be approximately an 8% degradation of - performance for nstore(), but it's now working as expected. - That cost may vary on your machine of course, since it is - solely caused by the memory allocation overhead used to create - unique SV tags for each distinct stored SV. - -Tue Jan 20 09:21:53 MET 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Don't use any '_' in version number. - -Tue Jan 13 17:51:50 MET 1998 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Updated version number. - - added binmode() calls for systems where it matters. - - Be sure to pass globs, not plain file strings, to C routines, - so that Storable can be used under the Perl debugger. - -Wed Nov 5 10:53:22 MET 1997 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Fix memory leaks on seen hash table and returned SV refs. - - Storable did not work properly when tainting enabled. - - Fixed "Allocation too large" messages in freeze/thaw and added. - proper regression test in t/freeze.t. - -Tue Jun 3 09:41:33 METDST 1997 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Updated version number - - Added freeze/thaw interface and dclone. - -Fri May 16 10:45:47 METDST 1997 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Forgot that AutoLoader does not export its own AUTOLOAD. - I could use - - use AutoLoader 'AUTOLOAD'; - - but that would not be backward compatible. So the export is - done by hand... - -Tue Mar 25 11:21:32 MET 1997 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Empty scalar strings are now "defined" at retrieval time. - - New test to ensure an empty string is defined when retrieved. - -Thu Feb 27 16:32:44 MET 1997 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Updated version number - - Declare VERSION as being used - - Fixed a typo in the PerlIO_putc remapping. - PerlIO_read and perlIO_write inverted size/nb_items. - (only relevant for pre-perl5.004 versions) - -Thu Feb 27 15:58:31 MET 1997 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Updated version number - - Added VERSION identification - - Allow build with perl5.003, which is ante perlIO time - -Mon Jan 13 17:53:18 MET 1997 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Random code fixes. - -Wed Jan 22 15:19:56 MET 1997 Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com> - - Updated version number in Makefile.PL. - - Added "thanks to" section to README. - - Documented new forgive_me variable. - - Made 64-bit clean. - - Added forgive_me support to allow store() of data structures - containing non-storable items like CODE refs. diff --git a/ext/Storable/Makefile.PL b/ext/Storable/Makefile.PL deleted file mode 100644 index b840b3919a..0000000000 --- a/ext/Storable/Makefile.PL +++ /dev/null @@ -1,39 +0,0 @@ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -use ExtUtils::MakeMaker; -use Config; - -WriteMakefile( - NAME => 'Storable', - DISTNAME => "Storable", -# We now ship this in t/ -# PREREQ_PM => { 'Test::More' => '0.41' }, - INSTALLDIRS => $] >= 5.007 ? 'perl' : 'site', - VERSION_FROM => 'Storable.pm', - dist => { SUFFIX => 'gz', COMPRESS => 'gzip -f' }, -); - -my $ivtype = $Config{ivtype}; - -# I don't know if the VMS folks ever supported long long on 5.6.x -if ($ivtype and $ivtype eq 'long long' and $^O !~ /^MSWin/) { - print <<'EOM'; - -You appear to have a perl configured to use 64 bit integers in its scalar -variables. If you have existing data written with an earlier version of -Storable which this version of Storable refuses to load with a - - Byte order is not compatible - -error, then please read the section "64 bit data in perl 5.6.0 and 5.6.1" -in the Storable documentation for instructions on how to read your data. - -(You can find the documentation at the end of Storable.pm in POD format) - -EOM -} diff --git a/ext/Storable/README b/ext/Storable/README deleted file mode 100644 index cb4589e161..0000000000 --- a/ext/Storable/README +++ /dev/null @@ -1,109 +0,0 @@ - Storable 2.14 - Copyright (c) 1995-2000, Raphael Manfredi - Copyright (c) 2001-2004, Larry Wall - ------------------------------------------------------------------------- - This program is free software; you can redistribute it and/or modify - it under the same terms as Perl 5 itself. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - Perl 5 License schemes for more details. ------------------------------------------------------------------------- - -+======================================================================= -| Storable is distributed as a module, but is also part of the official -| Perl core distribution, as of perl 5.8. -| Maintenance is now done by the perl5-porters. We thank Raphael -| Manfredi for providing us with this very useful module. -+======================================================================= - -The Storable extension brings persistency to your data. - -You may recursively store to disk any data structure, no matter how -complex and circular it is, provided it contains only SCALAR, ARRAY, -HASH (possibly tied) and references (possibly blessed) to those items. - -At a later stage, or in another program, you may retrieve data from -the stored file and recreate the same hiearchy in memory. If you -had blessed references, the retrieved references are blessed into -the same package, so you must make sure you have access to the -same perl class than the one used to create the relevant objects. - -There is also a dclone() routine which performs an optimized mirroring -of any data structure, preserving its topology. - -Objects (blessed references) may also redefine the way storage and -retrieval is performed, and/or what deep cloning should do on those -objects. - -To compile this extension, run: - - perl Makefile.PL [PERL_SRC=...where you put perl sources...] - make - make install - -There is an embeded POD manual page in Storable.pm. - -Storable was written by Raphael Manfredi <Raphael_Manfredi@pobox.com> -Maitainance is now done by the perl5-porters <perl5-porters@perl.org> - -Please e-mail us with problems, bug fixes, comments and complaints, -although if you have complements you should send them to Raphael. -Please don't e-mail Raphael with problems, as he no longer works on -Storable, and your message will be delayed while he forwards it to us. - ------------------------------------------------------------------------- -Thanks to (in chronological order): - - Jarkko Hietaniemi <jhi@iki.fi> - Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> - Benjamin A. Holzman <bah@ecnvantage.com> - Andrew Ford <A.Ford@ford-mason.co.uk> - Gisle Aas <gisle@aas.no> - Jeff Gresham <gresham_jeffrey@jpmorgan.com> - Murray Nesbitt <murray@activestate.com> - Albert N. Micheev <Albert.N.Micheev@f80.n5049.z2.fidonet.org> - Marc Lehmann <pcg@opengroup.org> - Justin Banks <justinb@wamnet.com> - Jarkko Hietaniemi <jhi@iki.fi> (AGAIN, as perl 5.7.0 Pumpkin!) - -for their contributions. - -A Japanese translation of this man page is available at the Japanized -Perl Resources Project <https://sourceforge.jp/projects/perldocjp/>. ------------------------------------------------------------------------- - -The perl5-porters would like to thank - - Raphael Manfredi <Raphael_Manfredi@pobox.com> - -According to the perl5.8 Changes file, the following people have helped -bring you this Storable release: - - Abhijit Menon-Sen <ams@wiw.org> - Andreas J. Koenig <andreas.koenig@anima.de> - Archer Sully <archer@meer.net> - Craig A. Berry <craig.berry@psinetcs.com> - Dan Kogai <dankogai@dan.co.jp> - Doug MacEachern <dougm@covalent.net> - Gurusamy Sarathy <gsar@ActiveState.com> - H.Merijn Brand <h.m.brand@xs4all.nl> - Jarkko Hietaniemi <jhi@iki.fi> - Mark Bixby - Michael Stevens <michael@etla.org> - Mike Guy <mjtg@cam.ac.uk> - Nicholas Clark <nick@unfortu.net> - Peter J. Farley III <pjfarley@banet.net> - Peter Prymmer <pvhp@forte.com> - Philip Newton <pne@cpan.org> - Raphael Manfredi <Raphael_Manfredi@pobox.com> - Robin Barker <rmb1@cise.npl.co.uk> - Radu Greab <radu@netsoft.ro> - Tim Bunce <Tim.Bunce@pobox.com> - VMSperlers - Yitzchak Scott-Thoennes <sthoenna@efn.org> - -If I've missed you out, please accept my apologies, and e-mail your -patch to perl5-porters@perl.org. diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm deleted file mode 100644 index 20df4f1e7d..0000000000 --- a/ext/Storable/Storable.pm +++ /dev/null @@ -1,1188 +0,0 @@ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -require DynaLoader; -require Exporter; -package Storable; @ISA = qw(Exporter DynaLoader); - -@EXPORT = qw(store retrieve); -@EXPORT_OK = qw( - nstore store_fd nstore_fd fd_retrieve - freeze nfreeze thaw - dclone - retrieve_fd - lock_store lock_nstore lock_retrieve - file_magic read_magic -); - -use AutoLoader; -use FileHandle; -use vars qw($canonical $forgive_me $VERSION); - -$VERSION = '2.20'; -*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... - -# -# Use of Log::Agent is optional -# - -{ - local $SIG{__DIE__}; - eval "use Log::Agent"; -} - -require Carp; - -# -# They might miss :flock in Fcntl -# - -BEGIN { - if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) { - Fcntl->import(':flock'); - } else { - eval q{ - sub LOCK_SH () {1} - sub LOCK_EX () {2} - }; - } -} - -sub CLONE { - # clone context under threads - Storable::init_perinterp(); -} - -# Can't Autoload cleanly as this clashes 8.3 with &retrieve -sub retrieve_fd { &fd_retrieve } # Backward compatibility - -# By default restricted hashes are downgraded on earlier perls. - -$Storable::downgrade_restricted = 1; -$Storable::accept_future_minor = 1; -bootstrap Storable; -1; -__END__ -# -# Use of Log::Agent is optional. If it hasn't imported these subs then -# Autoloader will kindly supply our fallback implementation. -# - -sub logcroak { - Carp::croak(@_); -} - -sub logcarp { - Carp::carp(@_); -} - -# -# Determine whether locking is possible, but only when needed. -# - -sub CAN_FLOCK; my $CAN_FLOCK; sub CAN_FLOCK { - return $CAN_FLOCK if defined $CAN_FLOCK; - require Config; import Config; - return $CAN_FLOCK = - $Config{'d_flock'} || - $Config{'d_fcntl_can_lock'} || - $Config{'d_lockf'}; -} - -sub show_file_magic { - print <<EOM; -# -# To recognize the data files of the Perl module Storable, -# the following lines need to be added to the local magic(5) file, -# usually either /usr/share/misc/magic or /etc/magic. -# -0 string perl-store perl Storable(v0.6) data ->4 byte >0 (net-order %d) ->>4 byte &01 (network-ordered) ->>4 byte =3 (major 1) ->>4 byte =2 (major 1) - -0 string pst0 perl Storable(v0.7) data ->4 byte >0 ->>4 byte &01 (network-ordered) ->>4 byte =5 (major 2) ->>4 byte =4 (major 2) ->>5 byte >0 (minor %d) -EOM -} - -sub file_magic { - my $file = shift; - my $fh = new FileHandle; - open($fh, "<". $file) || die "Can't open '$file': $!"; - binmode($fh); - defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!"; - close($fh); - - $file = "./$file" unless $file; # ensure TRUE value - - return read_magic($buf, $file); -} - -sub read_magic { - my($buf, $file) = @_; - my %info; - - my $buflen = length($buf); - my $magic; - if ($buf =~ s/^(pst0|perl-store)//) { - $magic = $1; - $info{file} = $file || 1; - } - else { - return undef if $file; - $magic = ""; - } - - return undef unless length($buf); - - my $net_order; - if ($magic eq "perl-store" && ord(substr($buf, 0, 1)) > 1) { - $info{version} = -1; - $net_order = 0; - } - else { - $net_order = ord(substr($buf, 0, 1, "")); - my $major = $net_order >> 1; - return undef if $major > 4; # sanity (assuming we never go that high) - $info{major} = $major; - $net_order &= 0x01; - if ($major > 1) { - return undef unless length($buf); - my $minor = ord(substr($buf, 0, 1, "")); - $info{minor} = $minor; - $info{version} = "$major.$minor"; - $info{version_nv} = sprintf "%d.%03d", $major, $minor; - } - else { - $info{version} = $major; - } - } - $info{version_nv} ||= $info{version}; - $info{netorder} = $net_order; - - unless ($net_order) { - return undef unless length($buf); - my $len = ord(substr($buf, 0, 1, "")); - return undef unless length($buf) >= $len; - return undef unless $len == 4 || $len == 8; # sanity - $info{byteorder} = substr($buf, 0, $len, ""); - $info{intsize} = ord(substr($buf, 0, 1, "")); - $info{longsize} = ord(substr($buf, 0, 1, "")); - $info{ptrsize} = ord(substr($buf, 0, 1, "")); - if ($info{version_nv} >= 2.002) { - return undef unless length($buf); - $info{nvsize} = ord(substr($buf, 0, 1, "")); - } - } - $info{hdrsize} = $buflen - length($buf); - - return \%info; -} - -sub BIN_VERSION_NV { - sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR(); -} - -sub BIN_WRITE_VERSION_NV { - sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR(); -} - -# -# store -# -# Store target object hierarchy, identified by a reference to its root. -# The stored object tree may later be retrieved to memory via retrieve. -# Returns undef if an I/O error occurred, in which case the file is -# removed. -# -sub store { - return _store(\&pstore, @_, 0); -} - -# -# nstore -# -# Same as store, but in network order. -# -sub nstore { - return _store(\&net_pstore, @_, 0); -} - -# -# lock_store -# -# Same as store, but flock the file first (advisory locking). -# -sub lock_store { - return _store(\&pstore, @_, 1); -} - -# -# lock_nstore -# -# Same as nstore, but flock the file first (advisory locking). -# -sub lock_nstore { - return _store(\&net_pstore, @_, 1); -} - -# Internal store to file routine -sub _store { - my $xsptr = shift; - my $self = shift; - my ($file, $use_locking) = @_; - logcroak "not a reference" unless ref($self); - logcroak "wrong argument number" unless @_ == 2; # No @foo in arglist - local *FILE; - if ($use_locking) { - open(FILE, ">>$file") || logcroak "can't write into $file: $!"; - unless (&CAN_FLOCK) { - logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O"; - return undef; - } - flock(FILE, LOCK_EX) || - logcroak "can't get exclusive lock on $file: $!"; - truncate FILE, 0; - # Unlocking will happen when FILE is closed - } else { - open(FILE, ">$file") || logcroak "can't create $file: $!"; - } - binmode FILE; # Archaic systems... - my $da = $@; # Don't mess if called from exception handler - my $ret; - # Call C routine nstore or pstore, depending on network order - eval { $ret = &$xsptr(*FILE, $self) }; - close(FILE) or $ret = undef; - unlink($file) or warn "Can't unlink $file: $!\n" if $@ || !defined $ret; - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $ret ? $ret : undef; -} - -# -# store_fd -# -# Same as store, but perform on an already opened file descriptor instead. -# Returns undef if an I/O error occurred. -# -sub store_fd { - return _store_fd(\&pstore, @_); -} - -# -# nstore_fd -# -# Same as store_fd, but in network order. -# -sub nstore_fd { - my ($self, $file) = @_; - return _store_fd(\&net_pstore, @_); -} - -# Internal store routine on opened file descriptor -sub _store_fd { - my $xsptr = shift; - my $self = shift; - my ($file) = @_; - logcroak "not a reference" unless ref($self); - logcroak "too many arguments" unless @_ == 1; # No @foo in arglist - my $fd = fileno($file); - logcroak "not a valid file descriptor" unless defined $fd; - my $da = $@; # Don't mess if called from exception handler - my $ret; - # Call C routine nstore or pstore, depending on network order - eval { $ret = &$xsptr($file, $self) }; - logcroak $@ if $@ =~ s/\.?\n$/,/; - local $\; print $file ''; # Autoflush the file if wanted - $@ = $da; - return $ret ? $ret : undef; -} - -# -# freeze -# -# Store oject and its hierarchy in memory and return a scalar -# containing the result. -# -sub freeze { - _freeze(\&mstore, @_); -} - -# -# nfreeze -# -# Same as freeze but in network order. -# -sub nfreeze { - _freeze(\&net_mstore, @_); -} - -# Internal freeze routine -sub _freeze { - my $xsptr = shift; - my $self = shift; - logcroak "not a reference" unless ref($self); - logcroak "too many arguments" unless @_ == 0; # No @foo in arglist - my $da = $@; # Don't mess if called from exception handler - my $ret; - # Call C routine mstore or net_mstore, depending on network order - eval { $ret = &$xsptr($self) }; - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $ret ? $ret : undef; -} - -# -# retrieve -# -# Retrieve object hierarchy from disk, returning a reference to the root -# object of that tree. -# -sub retrieve { - _retrieve($_[0], 0); -} - -# -# lock_retrieve -# -# Same as retrieve, but with advisory locking. -# -sub lock_retrieve { - _retrieve($_[0], 1); -} - -# Internal retrieve routine -sub _retrieve { - my ($file, $use_locking) = @_; - local *FILE; - open(FILE, $file) || logcroak "can't open $file: $!"; - binmode FILE; # Archaic systems... - my $self; - my $da = $@; # Could be from exception handler - if ($use_locking) { - unless (&CAN_FLOCK) { - logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O"; - return undef; - } - flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!"; - # Unlocking will happen when FILE is closed - } - eval { $self = pretrieve(*FILE) }; # Call C routine - close(FILE); - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $self; -} - -# -# fd_retrieve -# -# Same as retrieve, but perform from an already opened file descriptor instead. -# -sub fd_retrieve { - my ($file) = @_; - my $fd = fileno($file); - logcroak "not a valid file descriptor" unless defined $fd; - my $self; - my $da = $@; # Could be from exception handler - eval { $self = pretrieve($file) }; # Call C routine - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $self; -} - -# -# thaw -# -# Recreate objects in memory from an existing frozen image created -# by freeze. If the frozen image passed is undef, return undef. -# -sub thaw { - my ($frozen) = @_; - return undef unless defined $frozen; - my $self; - my $da = $@; # Could be from exception handler - eval { $self = mretrieve($frozen) }; # Call C routine - logcroak $@ if $@ =~ s/\.?\n$/,/; - $@ = $da; - return $self; -} - -1; -__END__ - -=head1 NAME - -Storable - persistence for Perl data structures - -=head1 SYNOPSIS - - use Storable; - store \%table, 'file'; - $hashref = retrieve('file'); - - use Storable qw(nstore store_fd nstore_fd freeze thaw dclone); - - # Network order - nstore \%table, 'file'; - $hashref = retrieve('file'); # There is NO nretrieve() - - # Storing to and retrieving from an already opened file - store_fd \@array, \*STDOUT; - nstore_fd \%table, \*STDOUT; - $aryref = fd_retrieve(\*SOCKET); - $hashref = fd_retrieve(\*SOCKET); - - # Serializing to memory - $serialized = freeze \%table; - %table_clone = %{ thaw($serialized) }; - - # Deep (recursive) cloning - $cloneref = dclone($ref); - - # Advisory locking - use Storable qw(lock_store lock_nstore lock_retrieve) - lock_store \%table, 'file'; - lock_nstore \%table, 'file'; - $hashref = lock_retrieve('file'); - -=head1 DESCRIPTION - -The Storable package brings persistence to your Perl data structures -containing SCALAR, ARRAY, HASH or REF objects, i.e. anything that can be -conveniently stored to disk and retrieved at a later time. - -It can be used in the regular procedural way by calling C<store> with -a reference to the object to be stored, along with the file name where -the image should be written. - -The routine returns C<undef> for I/O problems or other internal error, -a true value otherwise. Serious errors are propagated as a C<die> exception. - -To retrieve data stored to disk, use C<retrieve> with a file name. -The objects stored into that file are recreated into memory for you, -and a I<reference> to the root object is returned. In case an I/O error -occurs while reading, C<undef> is returned instead. Other serious -errors are propagated via C<die>. - -Since storage is performed recursively, you might want to stuff references -to objects that share a lot of common data into a single array or hash -table, and then store that object. That way, when you retrieve back the -whole thing, the objects will continue to share what they originally shared. - -At the cost of a slight header overhead, you may store to an already -opened file descriptor using the C<store_fd> routine, and retrieve -from a file via C<fd_retrieve>. Those names aren't imported by default, -so you will have to do that explicitly if you need those routines. -The file descriptor you supply must be already opened, for read -if you're going to retrieve and for write if you wish to store. - - store_fd(\%table, *STDOUT) || die "can't store to stdout\n"; - $hashref = fd_retrieve(*STDIN); - -You can also store data in network order to allow easy sharing across -multiple platforms, or when storing on a socket known to be remotely -connected. The routines to call have an initial C<n> prefix for I<network>, -as in C<nstore> and C<nstore_fd>. At retrieval time, your data will be -correctly restored so you don't have to know whether you're restoring -from native or network ordered data. Double values are stored stringified -to ensure portability as well, at the slight risk of loosing some precision -in the last decimals. - -When using C<fd_retrieve>, objects are retrieved in sequence, one -object (i.e. one recursive tree) per associated C<store_fd>. - -If you're more from the object-oriented camp, you can inherit from -Storable and directly store your objects by invoking C<store> as -a method. The fact that the root of the to-be-stored tree is a -blessed reference (i.e. an object) is special-cased so that the -retrieve does not provide a reference to that object but rather the -blessed object reference itself. (Otherwise, you'd get a reference -to that blessed object). - -=head1 MEMORY STORE - -The Storable engine can also store data into a Perl scalar instead, to -later retrieve them. This is mainly used to freeze a complex structure in -some safe compact memory place (where it can possibly be sent to another -process via some IPC, since freezing the structure also serializes it in -effect). Later on, and maybe somewhere else, you can thaw the Perl scalar -out and recreate the original complex structure in memory. - -Surprisingly, the routines to be called are named C<freeze> and C<thaw>. -If you wish to send out the frozen scalar to another machine, use -C<nfreeze> instead to get a portable image. - -Note that freezing an object structure and immediately thawing it -actually achieves a deep cloning of that structure: - - dclone(.) = thaw(freeze(.)) - -Storable provides you with a C<dclone> interface which does not create -that intermediary scalar but instead freezes the structure in some -internal memory space and then immediately thaws it out. - -=head1 ADVISORY LOCKING - -The C<lock_store> and C<lock_nstore> routine are equivalent to -C<store> and C<nstore>, except that they get an exclusive lock on -the file before writing. Likewise, C<lock_retrieve> does the same -as C<retrieve>, but also gets a shared lock on the file before reading. - -As with any advisory locking scheme, the protection only works if you -systematically use C<lock_store> and C<lock_retrieve>. If one side of -your application uses C<store> whilst the other uses C<lock_retrieve>, -you will get no protection at all. - -The internal advisory locking is implemented using Perl's flock() -routine. If your system does not support any form of flock(), or if -you share your files across NFS, you might wish to use other forms -of locking by using modules such as LockFile::Simple which lock a -file using a filesystem entry, instead of locking the file descriptor. - -=head1 SPEED - -The heart of Storable is written in C for decent speed. Extra low-level -optimizations have been made when manipulating perl internals, to -sacrifice encapsulation for the benefit of greater speed. - -=head1 CANONICAL REPRESENTATION - -Normally, Storable stores elements of hashes in the order they are -stored internally by Perl, i.e. pseudo-randomly. If you set -C<$Storable::canonical> to some C<TRUE> value, Storable will store -hashes with the elements sorted by their key. This allows you to -compare data structures by comparing their frozen representations (or -even the compressed frozen representations), which can be useful for -creating lookup tables for complicated queries. - -Canonical order does not imply network order; those are two orthogonal -settings. - -=head1 CODE REFERENCES - -Since Storable version 2.05, CODE references may be serialized with -the help of L<B::Deparse>. To enable this feature, set -C<$Storable::Deparse> to a true value. To enable deserialization, -C<$Storable::Eval> should be set to a true value. Be aware that -deserialization is done through C<eval>, which is dangerous if the -Storable file contains malicious data. You can set C<$Storable::Eval> -to a subroutine reference which would be used instead of C<eval>. See -below for an example using a L<Safe> compartment for deserialization -of CODE references. - -If C<$Storable::Deparse> and/or C<$Storable::Eval> are set to false -values, then the value of C<$Storable::forgive_me> (see below) is -respected while serializing and deserializing. - -=head1 FORWARD COMPATIBILITY - -This release of Storable can be used on a newer version of Perl to -serialize data which is not supported by earlier Perls. By default, -Storable will attempt to do the right thing, by C<croak()>ing if it -encounters data that it cannot deserialize. However, the defaults -can be changed as follows: - -=over 4 - -=item utf8 data - -Perl 5.6 added support for Unicode characters with code points > 255, -and Perl 5.8 has full support for Unicode characters in hash keys. -Perl internally encodes strings with these characters using utf8, and -Storable serializes them as utf8. By default, if an older version of -Perl encounters a utf8 value it cannot represent, it will C<croak()>. -To change this behaviour so that Storable deserializes utf8 encoded -values as the string of bytes (effectively dropping the I<is_utf8> flag) -set C<$Storable::drop_utf8> to some C<TRUE> value. This is a form of -data loss, because with C<$drop_utf8> true, it becomes impossible to tell -whether the original data was the Unicode string, or a series of bytes -that happen to be valid utf8. - -=item restricted hashes - -Perl 5.8 adds support for restricted hashes, which have keys -restricted to a given set, and can have values locked to be read only. -By default, when Storable encounters a restricted hash on a perl -that doesn't support them, it will deserialize it as a normal hash, -silently discarding any placeholder keys and leaving the keys and -all values unlocked. To make Storable C<croak()> instead, set -C<$Storable::downgrade_restricted> to a C<FALSE> value. To restore -the default set it back to some C<TRUE> value. - -=item files from future versions of Storable - -Earlier versions of Storable would immediately croak if they encountered -a file with a higher internal version number than the reading Storable -knew about. Internal version numbers are increased each time new data -types (such as restricted hashes) are added to the vocabulary of the file -format. This meant that a newer Storable module had no way of writing a -file readable by an older Storable, even if the writer didn't store newer -data types. - -This version of Storable will defer croaking until it encounters a data -type in the file that it does not recognize. This means that it will -continue to read files generated by newer Storable modules which are careful -in what they write out, making it easier to upgrade Storable modules in a -mixed environment. - -The old behaviour of immediate croaking can be re-instated by setting -C<$Storable::accept_future_minor> to some C<FALSE> value. - -=back - -All these variables have no effect on a newer Perl which supports the -relevant feature. - -=head1 ERROR REPORTING - -Storable uses the "exception" paradigm, in that it does not try to workaround -failures: if something bad happens, an exception is generated from the -caller's perspective (see L<Carp> and C<croak()>). Use eval {} to trap -those exceptions. - -When Storable croaks, it tries to report the error via the C<logcroak()> -routine from the C<Log::Agent> package, if it is available. - -Normal errors are reported by having store() or retrieve() return C<undef>. -Such errors are usually I/O errors (or truncated stream errors at retrieval). - -=head1 WIZARDS ONLY - -=head2 Hooks - -Any class may define hooks that will be called during the serialization -and deserialization process on objects that are instances of that class. -Those hooks can redefine the way serialization is performed (and therefore, -how the symmetrical deserialization should be conducted). - -Since we said earlier: - - dclone(.) = thaw(freeze(.)) - -everything we say about hooks should also hold for deep cloning. However, -hooks get to know whether the operation is a mere serialization, or a cloning. - -Therefore, when serializing hooks are involved, - - dclone(.) <> thaw(freeze(.)) - -Well, you could keep them in sync, but there's no guarantee it will always -hold on classes somebody else wrote. Besides, there is little to gain in -doing so: a serializing hook could keep only one attribute of an object, -which is probably not what should happen during a deep cloning of that -same object. - -Here is the hooking interface: - -=over 4 - -=item C<STORABLE_freeze> I<obj>, I<cloning> - -The serializing hook, called on the object during serialization. It can be -inherited, or defined in the class itself, like any other method. - -Arguments: I<obj> is the object to serialize, I<cloning> is a flag indicating -whether we're in a dclone() or a regular serialization via store() or freeze(). - -Returned value: A LIST C<($serialized, $ref1, $ref2, ...)> where $serialized -is the serialized form to be used, and the optional $ref1, $ref2, etc... are -extra references that you wish to let the Storable engine serialize. - -At deserialization time, you will be given back the same LIST, but all the -extra references will be pointing into the deserialized structure. - -The B<first time> the hook is hit in a serialization flow, you may have it -return an empty list. That will signal the Storable engine to further -discard that hook for this class and to therefore revert to the default -serialization of the underlying Perl data. The hook will again be normally -processed in the next serialization. - -Unless you know better, serializing hook should always say: - - sub STORABLE_freeze { - my ($self, $cloning) = @_; - return if $cloning; # Regular default serialization - .... - } - -in order to keep reasonable dclone() semantics. - -=item C<STORABLE_thaw> I<obj>, I<cloning>, I<serialized>, ... - -The deserializing hook called on the object during deserialization. -But wait: if we're deserializing, there's no object yet... right? - -Wrong: the Storable engine creates an empty one for you. If you know Eiffel, -you can view C<STORABLE_thaw> as an alternate creation routine. - -This means the hook can be inherited like any other method, and that -I<obj> is your blessed reference for this particular instance. - -The other arguments should look familiar if you know C<STORABLE_freeze>: -I<cloning> is true when we're part of a deep clone operation, I<serialized> -is the serialized string you returned to the engine in C<STORABLE_freeze>, -and there may be an optional list of references, in the same order you gave -them at serialization time, pointing to the deserialized objects (which -have been processed courtesy of the Storable engine). - -When the Storable engine does not find any C<STORABLE_thaw> hook routine, -it tries to load the class by requiring the package dynamically (using -the blessed package name), and then re-attempts the lookup. If at that -time the hook cannot be located, the engine croaks. Note that this mechanism -will fail if you define several classes in the same file, but L<perlmod> -warned you. - -It is up to you to use this information to populate I<obj> the way you want. - -Returned value: none. - -=item C<STORABLE_attach> I<class>, I<cloning>, I<serialized> - -While C<STORABLE_freeze> and C<STORABLE_thaw> are useful for classes where -each instance is independent, this mechanism has difficulty (or is -incompatible) with objects that exist as common process-level or -system-level resources, such as singleton objects, database pools, caches -or memoized objects. - -The alternative C<STORABLE_attach> method provides a solution for these -shared objects. Instead of C<STORABLE_freeze> --E<gt> C<STORABLE_thaw>, -you implement C<STORABLE_freeze> --E<gt> C<STORABLE_attach> instead. - -Arguments: I<class> is the class we are attaching to, I<cloning> is a flag -indicating whether we're in a dclone() or a regular de-serialization via -thaw(), and I<serialized> is the stored string for the resource object. - -Because these resource objects are considered to be owned by the entire -process/system, and not the "property" of whatever is being serialized, -no references underneath the object should be included in the serialized -string. Thus, in any class that implements C<STORABLE_attach>, the -C<STORABLE_freeze> method cannot return any references, and C<Storable> -will throw an error if C<STORABLE_freeze> tries to return references. - -All information required to "attach" back to the shared resource object -B<must> be contained B<only> in the C<STORABLE_freeze> return string. -Otherwise, C<STORABLE_freeze> behaves as normal for C<STORABLE_attach> -classes. - -Because C<STORABLE_attach> is passed the class (rather than an object), -it also returns the object directly, rather than modifying the passed -object. - -Returned value: object of type C<class> - -=back - -=head2 Predicates - -Predicates are not exportable. They must be called by explicitly prefixing -them with the Storable package name. - -=over 4 - -=item C<Storable::last_op_in_netorder> - -The C<Storable::last_op_in_netorder()> predicate will tell you whether -network order was used in the last store or retrieve operation. If you -don't know how to use this, just forget about it. - -=item C<Storable::is_storing> - -Returns true if within a store operation (via STORABLE_freeze hook). - -=item C<Storable::is_retrieving> - -Returns true if within a retrieve operation (via STORABLE_thaw hook). - -=back - -=head2 Recursion - -With hooks comes the ability to recurse back to the Storable engine. -Indeed, hooks are regular Perl code, and Storable is convenient when -it comes to serializing and deserializing things, so why not use it -to handle the serialization string? - -There are a few things you need to know, however: - -=over 4 - -=item * - -You can create endless loops if the things you serialize via freeze() -(for instance) point back to the object we're trying to serialize in -the hook. - -=item * - -Shared references among objects will not stay shared: if we're serializing -the list of object [A, C] where both object A and C refer to the SAME object -B, and if there is a serializing hook in A that says freeze(B), then when -deserializing, we'll get [A', C'] where A' refers to B', but C' refers to D, -a deep clone of B'. The topology was not preserved. - -=back - -That's why C<STORABLE_freeze> lets you provide a list of references -to serialize. The engine guarantees that those will be serialized in the -same context as the other objects, and therefore that shared objects will -stay shared. - -In the above [A, C] example, the C<STORABLE_freeze> hook could return: - - ("something", $self->{B}) - -and the B part would be serialized by the engine. In C<STORABLE_thaw>, you -would get back the reference to the B' object, deserialized for you. - -Therefore, recursion should normally be avoided, but is nonetheless supported. - -=head2 Deep Cloning - -There is a Clone module available on CPAN which implements deep cloning -natively, i.e. without freezing to memory and thawing the result. It is -aimed to replace Storable's dclone() some day. However, it does not currently -support Storable hooks to redefine the way deep cloning is performed. - -=head1 Storable magic - -Yes, there's a lot of that :-) But more precisely, in UNIX systems -there's a utility called C<file>, which recognizes data files based on -their contents (usually their first few bytes). For this to work, -a certain file called F<magic> needs to taught about the I<signature> -of the data. Where that configuration file lives depends on the UNIX -flavour; often it's something like F</usr/share/misc/magic> or -F</etc/magic>. Your system administrator needs to do the updating of -the F<magic> file. The necessary signature information is output to -STDOUT by invoking Storable::show_file_magic(). Note that the GNU -implementation of the C<file> utility, version 3.38 or later, -is expected to contain support for recognising Storable files -out-of-the-box, in addition to other kinds of Perl files. - -You can also use the following functions to extract the file header -information from Storable images: - -=over - -=item $info = Storable::file_magic( $filename ) - -If the given file is a Storable image return a hash describing it. If -the file is readable, but not a Storable image return C<undef>. If -the file does not exist or is unreadable then croak. - -The hash returned has the following elements: - -=over - -=item C<version> - -This returns the file format version. It is a string like "2.7". - -Note that this version number is not the same as the version number of -the Storable module itself. For instance Storable v0.7 create files -in format v2.0 and Storable v2.15 create files in format v2.7. The -file format version number only increment when additional features -that would confuse older versions of the module are added. - -Files older than v2.0 will have the one of the version numbers "-1", -"0" or "1". No minor number was used at that time. - -=item C<version_nv> - -This returns the file format version as number. It is a string like -"2.007". This value is suitable for numeric comparisons. - -The constant function C<Storable::BIN_VERSION_NV> returns a comparable -number that represent the highest file version number that this -version of Storable fully support (but see discussion of -C<$Storable::accept_future_minor> above). The constant -C<Storable::BIN_WRITE_VERSION_NV> function returns what file version -is written and might be less than C<Storable::BIN_VERSION_NV> in some -configuations. - -=item C<major>, C<minor> - -This also returns the file format version. If the version is "2.7" -then major would be 2 and minor would be 7. The minor element is -missing for when major is less than 2. - -=item C<hdrsize> - -The is the number of bytes that the Storable header occupies. - -=item C<netorder> - -This is TRUE if the image store data in network order. This means -that it was created with nstore() or similar. - -=item C<byteorder> - -This is only present when C<netorder> is FALSE. It is the -$Config{byteorder} string of the perl that created this image. It is -a string like "1234" (32 bit little endian) or "87654321" (64 bit big -endian). This must match the current perl for the image to be -readable by Storable. - -=item C<intsize>, C<longsize>, C<ptrsize>, C<nvsize> - -These are only present when C<netorder> is FALSE. These are the sizes of -various C datatypes of the perl that created this image. These must -match the current perl for the image to be readable by Storable. - -The C<nvsize> element is only present for file format v2.2 and -higher. - -=item C<file> - -The name of the file. - -=back - -=item $info = Storable::read_magic( $buffer ) - -=item $info = Storable::read_magic( $buffer, $must_be_file ) - -The $buffer should be a Storable image or the first few bytes of it. -If $buffer starts with a Storable header, then a hash describing the -image is returned, otherwise C<undef> is returned. - -The hash has the same structure as the one returned by -Storable::file_magic(). The C<file> element is true if the image is a -file image. - -If the $must_be_file argument is provided and is TRUE, then return -C<undef> unless the image looks like it belongs to a file dump. - -The maximum size of a Storable header is currently 21 bytes. If the -provided $buffer is only the first part of a Storable image it should -at least be this long to ensure that read_magic() will recognize it as -such. - -=back - -=head1 EXAMPLES - -Here are some code samples showing a possible usage of Storable: - - use Storable qw(store retrieve freeze thaw dclone); - - %color = ('Blue' => 0.1, 'Red' => 0.8, 'Black' => 0, 'White' => 1); - - store(\%color, 'mycolors') or die "Can't store %a in mycolors!\n"; - - $colref = retrieve('mycolors'); - die "Unable to retrieve from mycolors!\n" unless defined $colref; - printf "Blue is still %lf\n", $colref->{'Blue'}; - - $colref2 = dclone(\%color); - - $str = freeze(\%color); - printf "Serialization of %%color is %d bytes long.\n", length($str); - $colref3 = thaw($str); - -which prints (on my machine): - - Blue is still 0.100000 - Serialization of %color is 102 bytes long. - -Serialization of CODE references and deserialization in a safe -compartment: - -=for example begin - - use Storable qw(freeze thaw); - use Safe; - use strict; - my $safe = new Safe; - # because of opcodes used in "use strict": - $safe->permit(qw(:default require)); - local $Storable::Deparse = 1; - local $Storable::Eval = sub { $safe->reval($_[0]) }; - my $serialized = freeze(sub { 42 }); - my $code = thaw($serialized); - $code->() == 42; - -=for example end - -=for example_testing - is( $code->(), 42 ); - -=head1 WARNING - -If you're using references as keys within your hash tables, you're bound -to be disappointed when retrieving your data. Indeed, Perl stringifies -references used as hash table keys. If you later wish to access the -items via another reference stringification (i.e. using the same -reference that was used for the key originally to record the value into -the hash table), it will work because both references stringify to the -same string. - -It won't work across a sequence of C<store> and C<retrieve> operations, -however, because the addresses in the retrieved objects, which are -part of the stringified references, will probably differ from the -original addresses. The topology of your structure is preserved, -but not hidden semantics like those. - -On platforms where it matters, be sure to call C<binmode()> on the -descriptors that you pass to Storable functions. - -Storing data canonically that contains large hashes can be -significantly slower than storing the same data normally, as -temporary arrays to hold the keys for each hash have to be allocated, -populated, sorted and freed. Some tests have shown a halving of the -speed of storing -- the exact penalty will depend on the complexity of -your data. There is no slowdown on retrieval. - -=head1 BUGS - -You can't store GLOB, FORMLINE, etc.... If you can define semantics -for those operations, feel free to enhance Storable so that it can -deal with them. - -The store functions will C<croak> if they run into such references -unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that -case, the fatal message is turned in a warning and some -meaningless string is stored instead. - -Setting C<$Storable::canonical> may not yield frozen strings that -compare equal due to possible stringification of numbers. When the -string version of a scalar exists, it is the form stored; therefore, -if you happen to use your numbers as strings between two freezing -operations on the same data structures, you will get different -results. - -When storing doubles in network order, their value is stored as text. -However, you should also not expect non-numeric floating-point values -such as infinity and "not a number" to pass successfully through a -nstore()/retrieve() pair. - -As Storable neither knows nor cares about character sets (although it -does know that characters may be more than eight bits wide), any difference -in the interpretation of character codes between a host and a target -system is your problem. In particular, if host and target use different -code points to represent the characters used in the text representation -of floating-point numbers, you will not be able be able to exchange -floating-point data, even with nstore(). - -C<Storable::drop_utf8> is a blunt tool. There is no facility either to -return B<all> strings as utf8 sequences, or to attempt to convert utf8 -data back to 8 bit and C<croak()> if the conversion fails. - -Prior to Storable 2.01, no distinction was made between signed and -unsigned integers on storing. By default Storable prefers to store a -scalars string representation (if it has one) so this would only cause -problems when storing large unsigned integers that had never been converted -to string or floating point. In other words values that had been generated -by integer operations such as logic ops and then not used in any string or -arithmetic context before storing. - -=head2 64 bit data in perl 5.6.0 and 5.6.1 - -This section only applies to you if you have existing data written out -by Storable 2.02 or earlier on perl 5.6.0 or 5.6.1 on Unix or Linux which -has been configured with 64 bit integer support (not the default) -If you got a precompiled perl, rather than running Configure to build -your own perl from source, then it almost certainly does not affect you, -and you can stop reading now (unless you're curious). If you're using perl -on Windows it does not affect you. - -Storable writes a file header which contains the sizes of various C -language types for the C compiler that built Storable (when not writing in -network order), and will refuse to load files written by a Storable not -on the same (or compatible) architecture. This check and a check on -machine byteorder is needed because the size of various fields in the file -are given by the sizes of the C language types, and so files written on -different architectures are incompatible. This is done for increased speed. -(When writing in network order, all fields are written out as standard -lengths, which allows full interworking, but takes longer to read and write) - -Perl 5.6.x introduced the ability to optional configure the perl interpreter -to use C's C<long long> type to allow scalars to store 64 bit integers on 32 -bit systems. However, due to the way the Perl configuration system -generated the C configuration files on non-Windows platforms, and the way -Storable generates its header, nothing in the Storable file header reflected -whether the perl writing was using 32 or 64 bit integers, despite the fact -that Storable was storing some data differently in the file. Hence Storable -running on perl with 64 bit integers will read the header from a file -written by a 32 bit perl, not realise that the data is actually in a subtly -incompatible format, and then go horribly wrong (possibly crashing) if it -encountered a stored integer. This is a design failure. - -Storable has now been changed to write out and read in a file header with -information about the size of integers. It's impossible to detect whether -an old file being read in was written with 32 or 64 bit integers (they have -the same header) so it's impossible to automatically switch to a correct -backwards compatibility mode. Hence this Storable defaults to the new, -correct behaviour. - -What this means is that if you have data written by Storable 1.x running -on perl 5.6.0 or 5.6.1 configured with 64 bit integers on Unix or Linux -then by default this Storable will refuse to read it, giving the error -I<Byte order is not compatible>. If you have such data then you you -should set C<$Storable::interwork_56_64bit> to a true value to make this -Storable read and write files with the old header. You should also -migrate your data, or any older perl you are communicating with, to this -current version of Storable. - -If you don't have data written with specific configuration of perl described -above, then you do not and should not do anything. Don't set the flag - -not only will Storable on an identically configured perl refuse to load them, -but Storable a differently configured perl will load them believing them -to be correct for it, and then may well fail or crash part way through -reading them. - -=head1 CREDITS - -Thank you to (in chronological order): - - Jarkko Hietaniemi <jhi@iki.fi> - Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> - Benjamin A. Holzman <bah@ecnvantage.com> - Andrew Ford <A.Ford@ford-mason.co.uk> - Gisle Aas <gisle@aas.no> - Jeff Gresham <gresham_jeffrey@jpmorgan.com> - Murray Nesbitt <murray@activestate.com> - Marc Lehmann <pcg@opengroup.org> - Justin Banks <justinb@wamnet.com> - Jarkko Hietaniemi <jhi@iki.fi> (AGAIN, as perl 5.7.0 Pumpkin!) - Salvador Ortiz Garcia <sog@msg.com.mx> - Dominic Dunlop <domo@computer.org> - Erik Haugan <erik@solbors.no> - -for their bug reports, suggestions and contributions. - -Benjamin Holzman contributed the tied variable support, Andrew Ford -contributed the canonical order for hashes, and Gisle Aas fixed -a few misunderstandings of mine regarding the perl internals, -and optimized the emission of "tags" in the output streams by -simply counting the objects instead of tagging them (leading to -a binary incompatibility for the Storable image starting at version -0.6--older images are, of course, still properly understood). -Murray Nesbitt made Storable thread-safe. Marc Lehmann added overloading -and references to tied items support. - -=head1 AUTHOR - -Storable was written by Raphael Manfredi F<E<lt>Raphael_Manfredi@pobox.comE<gt>> -Maintenance is now done by the perl5-porters F<E<lt>perl5-porters@perl.orgE<gt>> - -Please e-mail us with problems, bug fixes, comments and complaints, -although if you have compliments you should send them to Raphael. -Please don't e-mail Raphael with problems, as he no longer works on -Storable, and your message will be delayed while he forwards it to us. - -=head1 SEE ALSO - -L<Clone>. - -=cut diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs deleted file mode 100644 index 2741c7d30e..0000000000 --- a/ext/Storable/Storable.xs +++ /dev/null @@ -1,6491 +0,0 @@ -/* - * Store and retrieve mechanism. - * - * Copyright (c) 1995-2000, Raphael Manfredi - * - * You may redistribute only under the same terms as Perl 5, as specified - * in the README file that comes with the distribution. - * - */ - -#define PERL_NO_GET_CONTEXT /* we want efficiency */ -#include <EXTERN.h> -#include <perl.h> -#include <XSUB.h> - -#ifndef PATCHLEVEL -#include <patchlevel.h> /* Perl's one, needed since 5.6 */ -#endif - -#if !defined(PERL_VERSION) || PERL_VERSION < 8 -#define NEED_load_module -#define NEED_vload_module -#define NEED_newCONSTSUB -#include "ppport.h" /* handle old perls */ -#endif - -#if 0 -#define DEBUGME /* Debug mode, turns assertions on as well */ -#define DASSERT /* Assertion mode */ -#endif - -/* - * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined - * Provide them with the necessary defines so they can build with pre-5.004. - */ -#ifndef USE_PERLIO -#ifndef PERLIO_IS_STDIO -#define PerlIO FILE -#define PerlIO_getc(x) getc(x) -#define PerlIO_putc(f,x) putc(x,f) -#define PerlIO_read(x,y,z) fread(y,1,z,x) -#define PerlIO_write(x,y,z) fwrite(y,1,z,x) -#define PerlIO_stdoutf printf -#endif /* PERLIO_IS_STDIO */ -#endif /* USE_PERLIO */ - -/* - * Earlier versions of perl might be used, we can't assume they have the latest! - */ - -#ifndef PERL_VERSION /* For perls < 5.6 */ -#define PERL_VERSION PATCHLEVEL -#ifndef newRV_noinc -#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv) -#endif -#if (PATCHLEVEL <= 4) /* Older perls (<= 5.004) lack PL_ namespace */ -#define PL_sv_yes sv_yes -#define PL_sv_no sv_no -#define PL_sv_undef sv_undef -#if (SUBVERSION <= 4) /* 5.004_04 has been reported to lack newSVpvn */ -#define newSVpvn newSVpv -#endif -#endif /* PATCHLEVEL <= 4 */ -#ifndef HvSHAREKEYS_off -#define HvSHAREKEYS_off(hv) /* Ignore */ -#endif -#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */ -#define AvFILLp AvFILL -#endif -typedef double NV; /* Older perls lack the NV type */ -#define IVdf "ld" /* Various printf formats for Perl types */ -#define UVuf "lu" -#define UVof "lo" -#define UVxf "lx" -#define INT2PTR(t,v) (t)(IV)(v) -#define PTR2UV(v) (unsigned long)(v) -#endif /* PERL_VERSION -- perls < 5.6 */ - -#ifndef NVef /* The following were not part of perl 5.6 */ -#if defined(USE_LONG_DOUBLE) && \ - defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) -#define NVef PERL_PRIeldbl -#define NVff PERL_PRIfldbl -#define NVgf PERL_PRIgldbl -#else -#define NVef "e" -#define NVff "f" -#define NVgf "g" -#endif -#endif - -#ifndef SvRV_set -#define SvRV_set(sv, val) \ - STMT_START { \ - assert(SvTYPE(sv) >= SVt_RV); \ - (((XRV*)SvANY(sv))->xrv_rv = (val)); \ - } STMT_END -#endif - -#ifndef PERL_UNUSED_DECL -# ifdef HASATTRIBUTE -# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) -# define PERL_UNUSED_DECL -# else -# define PERL_UNUSED_DECL __attribute__((unused)) -# endif -# else -# define PERL_UNUSED_DECL -# endif -#endif - -#ifndef dNOOP -#define dNOOP extern int Perl___notused PERL_UNUSED_DECL -#endif - -#ifndef dVAR -#define dVAR dNOOP -#endif - -#ifndef HvRITER_set -# define HvRITER_set(hv,r) (HvRITER(hv) = r) -#endif -#ifndef HvEITER_set -# define HvEITER_set(hv,r) (HvEITER(hv) = r) -#endif - -#ifndef HvRITER_get -# define HvRITER_get HvRITER -#endif -#ifndef HvEITER_get -# define HvEITER_get HvEITER -#endif - -#ifndef HvNAME_get -#define HvNAME_get HvNAME -#endif - -#ifndef HvPLACEHOLDERS_get -# define HvPLACEHOLDERS_get HvPLACEHOLDERS -#endif - -#ifdef DEBUGME - -#ifndef DASSERT -#define DASSERT -#endif - -/* - * TRACEME() will only output things when the $Storable::DEBUGME is true. - */ - -#define TRACEME(x) \ - STMT_START { \ - if (SvTRUE(perl_get_sv("Storable::DEBUGME", GV_ADD))) \ - { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ - } STMT_END -#else -#define TRACEME(x) -#endif /* DEBUGME */ - -#ifdef DASSERT -#define ASSERT(x,y) \ - STMT_START { \ - if (!(x)) { \ - PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \ - __FILE__, __LINE__); \ - PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \ - } \ - } STMT_END -#else -#define ASSERT(x,y) -#endif - -/* - * Type markers. - */ - -#define C(x) ((char) (x)) /* For markers with dynamic retrieval handling */ - -#define SX_OBJECT C(0) /* Already stored object */ -#define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */ -#define SX_ARRAY C(2) /* Array forthcominng (size, item list) */ -#define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */ -#define SX_REF C(4) /* Reference to object forthcoming */ -#define SX_UNDEF C(5) /* Undefined scalar */ -#define SX_INTEGER C(6) /* Integer forthcoming */ -#define SX_DOUBLE C(7) /* Double forthcoming */ -#define SX_BYTE C(8) /* (signed) byte forthcoming */ -#define SX_NETINT C(9) /* Integer in network order forthcoming */ -#define SX_SCALAR C(10) /* Scalar (binary, small) follows (length, data) */ -#define SX_TIED_ARRAY C(11) /* Tied array forthcoming */ -#define SX_TIED_HASH C(12) /* Tied hash forthcoming */ -#define SX_TIED_SCALAR C(13) /* Tied scalar forthcoming */ -#define SX_SV_UNDEF C(14) /* Perl's immortal PL_sv_undef */ -#define SX_SV_YES C(15) /* Perl's immortal PL_sv_yes */ -#define SX_SV_NO C(16) /* Perl's immortal PL_sv_no */ -#define SX_BLESS C(17) /* Object is blessed */ -#define SX_IX_BLESS C(18) /* Object is blessed, classname given by index */ -#define SX_HOOK C(19) /* Stored via hook, user-defined */ -#define SX_OVERLOAD C(20) /* Overloaded reference */ -#define SX_TIED_KEY C(21) /* Tied magic key forthcoming */ -#define SX_TIED_IDX C(22) /* Tied magic index forthcoming */ -#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */ -#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */ -#define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */ -#define SX_CODE C(26) /* Code references as perl source code */ -#define SX_WEAKREF C(27) /* Weak reference to object forthcoming */ -#define SX_WEAKOVERLOAD C(28) /* Overloaded weak reference */ -#define SX_ERROR C(29) /* Error */ - -/* - * Those are only used to retrieve "old" pre-0.6 binary images. - */ -#define SX_ITEM 'i' /* An array item introducer */ -#define SX_IT_UNDEF 'I' /* Undefined array item */ -#define SX_KEY 'k' /* A hash key introducer */ -#define SX_VALUE 'v' /* A hash value introducer */ -#define SX_VL_UNDEF 'V' /* Undefined hash value */ - -/* - * Those are only used to retrieve "old" pre-0.7 binary images - */ - -#define SX_CLASS 'b' /* Object is blessed, class name length <255 */ -#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */ -#define SX_STORED 'X' /* End of object */ - -/* - * Limits between short/long length representation. - */ - -#define LG_SCALAR 255 /* Large scalar length limit */ -#define LG_BLESS 127 /* Large classname bless limit */ - -/* - * Operation types - */ - -#define ST_STORE 0x1 /* Store operation */ -#define ST_RETRIEVE 0x2 /* Retrieval operation */ -#define ST_CLONE 0x4 /* Deep cloning operation */ - -/* - * The following structure is used for hash table key retrieval. Since, when - * retrieving objects, we'll be facing blessed hash references, it's best - * to pre-allocate that buffer once and resize it as the need arises, never - * freeing it (keys will be saved away someplace else anyway, so even large - * keys are not enough a motivation to reclaim that space). - * - * This structure is also used for memory store/retrieve operations which - * happen in a fixed place before being malloc'ed elsewhere if persistency - * is required. Hence the aptr pointer. - */ -struct extendable { - char *arena; /* Will hold hash key strings, resized as needed */ - STRLEN asiz; /* Size of aforementionned buffer */ - char *aptr; /* Arena pointer, for in-place read/write ops */ - char *aend; /* First invalid address */ -}; - -/* - * At store time: - * A hash table records the objects which have already been stored. - * Those are referred to as SX_OBJECT in the file, and their "tag" (i.e. - * an arbitrary sequence number) is used to identify them. - * - * At retrieve time: - * An array table records the objects which have already been retrieved, - * as seen by the tag determind by counting the objects themselves. The - * reference to that retrieved object is kept in the table, and is returned - * when an SX_OBJECT is found bearing that same tag. - * - * The same processing is used to record "classname" for blessed objects: - * indexing by a hash at store time, and via an array at retrieve time. - */ - -typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ - -/* - * The following "thread-safe" related defines were contributed by - * Murray Nesbitt <murray@activestate.com> and integrated by RAM, who - * only renamed things a little bit to ensure consistency with surrounding - * code. -- RAM, 14/09/1999 - * - * The original patch suffered from the fact that the stcxt_t structure - * was global. Murray tried to minimize the impact on the code as much as - * possible. - * - * Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks - * on objects. Therefore, the notion of context needs to be generalized, - * threading or not. - */ - -#define MY_VERSION "Storable(" XS_VERSION ")" - - -/* - * Conditional UTF8 support. - * - */ -#ifdef SvUTF8_on -#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR) -#define HAS_UTF8_SCALARS -#ifdef HeKUTF8 -#define HAS_UTF8_HASHES -#define HAS_UTF8_ALL -#else -/* 5.6 perl has utf8 scalars but not hashes */ -#endif -#else -#define SvUTF8(sv) 0 -#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl")) -#endif -#ifndef HAS_UTF8_ALL -#define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl")) -#endif -#ifndef SvWEAKREF -#define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl")) -#endif - -#ifdef HvPLACEHOLDERS -#define HAS_RESTRICTED_HASHES -#else -#define HVhek_PLACEHOLD 0x200 -#define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash")) -#endif - -#ifdef HvHASKFLAGS -#define HAS_HASH_KEY_FLAGS -#endif - -#ifdef ptr_table_new -#define USE_PTR_TABLE -#endif - -/* - * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include - * files remap tainted and dirty when threading is enabled. That's bad for - * perl to remap such common words. -- RAM, 29/09/00 - */ - -struct stcxt; -typedef struct stcxt { - int entry; /* flags recursion */ - int optype; /* type of traversal operation */ - /* which objects have been seen, store time. - tags are numbers, which are cast to (SV *) and stored directly */ -#ifdef USE_PTR_TABLE - /* use pseen if we have ptr_tables. We have to store tag+1, because - tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table - without it being confused for a fetch lookup failure. */ - struct ptr_tbl *pseen; - /* Still need hseen for the 0.6 file format code. */ -#endif - HV *hseen; - AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */ - AV *aseen; /* which objects have been seen, retrieve time */ - IV where_is_undef; /* index in aseen of PL_sv_undef */ - HV *hclass; /* which classnames have been seen, store time */ - AV *aclass; /* which classnames have been seen, retrieve time */ - HV *hook; /* cache for hook methods per class name */ - IV tagnum; /* incremented at store time for each seen object */ - IV classnum; /* incremented at store time for each seen classname */ - int netorder; /* true if network order used */ - int s_tainted; /* true if input source is tainted, at retrieve time */ - int forgive_me; /* whether to be forgiving... */ - int deparse; /* whether to deparse code refs */ - SV *eval; /* whether to eval source code */ - int canonical; /* whether to store hashes sorted by key */ -#ifndef HAS_RESTRICTED_HASHES - int derestrict; /* whether to downgrade restrcted hashes */ -#endif -#ifndef HAS_UTF8_ALL - int use_bytes; /* whether to bytes-ify utf8 */ -#endif - int accept_future_minor; /* croak immediately on future minor versions? */ - int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */ - int membuf_ro; /* true means membuf is read-only and msaved is rw */ - struct extendable keybuf; /* for hash key retrieval */ - struct extendable membuf; /* for memory store/retrieve operations */ - struct extendable msaved; /* where potentially valid mbuf is saved */ - PerlIO *fio; /* where I/O are performed, NULL for memory */ - int ver_major; /* major of version for retrieved object */ - int ver_minor; /* minor of version for retrieved object */ - SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *); /* retrieve dispatch table */ - SV *prev; /* contexts chained backwards in real recursion */ - SV *my_sv; /* the blessed scalar who's SvPVX() I am */ -} stcxt_t; - -#define NEW_STORABLE_CXT_OBJ(cxt) \ - STMT_START { \ - SV *self = newSV(sizeof(stcxt_t) - 1); \ - SV *my_sv = newRV_noinc(self); \ - sv_bless(my_sv, gv_stashpv("Storable::Cxt", GV_ADD)); \ - cxt = (stcxt_t *)SvPVX(self); \ - Zero(cxt, 1, stcxt_t); \ - cxt->my_sv = my_sv; \ - } STMT_END - -#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI) - -#if (PATCHLEVEL <= 4) && (SUBVERSION < 68) -#define dSTCXT_SV \ - SV *perinterp_sv = perl_get_sv(MY_VERSION, 0) -#else /* >= perl5.004_68 */ -#define dSTCXT_SV \ - SV *perinterp_sv = *hv_fetch(PL_modglobal, \ - MY_VERSION, sizeof(MY_VERSION)-1, TRUE) -#endif /* < perl5.004_68 */ - -#define dSTCXT_PTR(T,name) \ - T name = ((perinterp_sv && SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \ - ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0)) -#define dSTCXT \ - dSTCXT_SV; \ - dSTCXT_PTR(stcxt_t *, cxt) - -#define INIT_STCXT \ - dSTCXT; \ - NEW_STORABLE_CXT_OBJ(cxt); \ - sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv)) - -#define SET_STCXT(x) \ - STMT_START { \ - dSTCXT_SV; \ - sv_setiv(perinterp_sv, PTR2IV(x->my_sv)); \ - } STMT_END - -#else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */ - -static stcxt_t *Context_ptr = NULL; -#define dSTCXT stcxt_t *cxt = Context_ptr -#define SET_STCXT(x) Context_ptr = x -#define INIT_STCXT \ - dSTCXT; \ - NEW_STORABLE_CXT_OBJ(cxt); \ - SET_STCXT(cxt) - - -#endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */ - -/* - * KNOWN BUG: - * Croaking implies a memory leak, since we don't use setjmp/longjmp - * to catch the exit and free memory used during store or retrieve - * operations. This is not too difficult to fix, but I need to understand - * how Perl does it, and croaking is exceptional anyway, so I lack the - * motivation to do it. - * - * The current workaround is to mark the context as dirty when croaking, - * so that data structures can be freed whenever we renter Storable code - * (but only *then*: it's a workaround, not a fix). - * - * This is also imperfect, because we don't really know how far they trapped - * the croak(), and when we were recursing, we won't be able to clean anything - * but the topmost context stacked. - */ - -#define CROAK(x) STMT_START { cxt->s_dirty = 1; croak x; } STMT_END - -/* - * End of "thread-safe" related definitions. - */ - -/* - * LOW_32BITS - * - * Keep only the low 32 bits of a pointer (used for tags, which are not - * really pointers). - */ - -#if PTRSIZE <= 4 -#define LOW_32BITS(x) ((I32) (x)) -#else -#define LOW_32BITS(x) ((I32) ((unsigned long) (x) & 0xffffffffUL)) -#endif - -/* - * oI, oS, oC - * - * Hack for Crays, where sizeof(I32) == 8, and which are big-endians. - * Used in the WLEN and RLEN macros. - */ - -#if INTSIZE > 4 -#define oI(x) ((I32 *) ((char *) (x) + 4)) -#define oS(x) ((x) - 4) -#define oC(x) (x = 0) -#define CRAY_HACK -#else -#define oI(x) (x) -#define oS(x) (x) -#define oC(x) -#endif - -/* - * key buffer handling - */ -#define kbuf (cxt->keybuf).arena -#define ksiz (cxt->keybuf).asiz -#define KBUFINIT() \ - STMT_START { \ - if (!kbuf) { \ - TRACEME(("** allocating kbuf of 128 bytes")); \ - New(10003, kbuf, 128, char); \ - ksiz = 128; \ - } \ - } STMT_END -#define KBUFCHK(x) \ - STMT_START { \ - if (x >= ksiz) { \ - TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \ - Renew(kbuf, x+1, char); \ - ksiz = x+1; \ - } \ - } STMT_END - -/* - * memory buffer handling - */ -#define mbase (cxt->membuf).arena -#define msiz (cxt->membuf).asiz -#define mptr (cxt->membuf).aptr -#define mend (cxt->membuf).aend - -#define MGROW (1 << 13) -#define MMASK (MGROW - 1) - -#define round_mgrow(x) \ - ((unsigned long) (((unsigned long) (x) + MMASK) & ~MMASK)) -#define trunc_int(x) \ - ((unsigned long) ((unsigned long) (x) & ~(sizeof(int)-1))) -#define int_aligned(x) \ - ((unsigned long) (x) == trunc_int(x)) - -#define MBUF_INIT(x) \ - STMT_START { \ - if (!mbase) { \ - TRACEME(("** allocating mbase of %d bytes", MGROW)); \ - New(10003, mbase, MGROW, char); \ - msiz = (STRLEN)MGROW; \ - } \ - mptr = mbase; \ - if (x) \ - mend = mbase + x; \ - else \ - mend = mbase + msiz; \ - } STMT_END - -#define MBUF_TRUNC(x) mptr = mbase + x -#define MBUF_SIZE() (mptr - mbase) - -/* - * MBUF_SAVE_AND_LOAD - * MBUF_RESTORE - * - * Those macros are used in do_retrieve() to save the current memory - * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve - * data from a string. - */ -#define MBUF_SAVE_AND_LOAD(in) \ - STMT_START { \ - ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \ - cxt->membuf_ro = 1; \ - TRACEME(("saving mbuf")); \ - StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \ - MBUF_LOAD(in); \ - } STMT_END - -#define MBUF_RESTORE() \ - STMT_START { \ - ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ - cxt->membuf_ro = 0; \ - TRACEME(("restoring mbuf")); \ - StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \ - } STMT_END - -/* - * Use SvPOKp(), because SvPOK() fails on tainted scalars. - * See store_scalar() for other usage of this workaround. - */ -#define MBUF_LOAD(v) \ - STMT_START { \ - ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ - if (!SvPOKp(v)) \ - CROAK(("Not a scalar string")); \ - mptr = mbase = SvPV(v, msiz); \ - mend = mbase + msiz; \ - } STMT_END - -#define MBUF_XTEND(x) \ - STMT_START { \ - int nsz = (int) round_mgrow((x)+msiz); \ - int offset = mptr - mbase; \ - ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \ - TRACEME(("** extending mbase from %d to %d bytes (wants %d new)", \ - msiz, nsz, (x))); \ - Renew(mbase, nsz, char); \ - msiz = nsz; \ - mptr = mbase + offset; \ - mend = mbase + nsz; \ - } STMT_END - -#define MBUF_CHK(x) \ - STMT_START { \ - if ((mptr + (x)) > mend) \ - MBUF_XTEND(x); \ - } STMT_END - -#define MBUF_GETC(x) \ - STMT_START { \ - if (mptr < mend) \ - x = (int) (unsigned char) *mptr++; \ - else \ - return (SV *) 0; \ - } STMT_END - -#ifdef CRAY_HACK -#define MBUF_GETINT(x) \ - STMT_START { \ - oC(x); \ - if ((mptr + 4) <= mend) { \ - memcpy(oI(&x), mptr, 4); \ - mptr += 4; \ - } else \ - return (SV *) 0; \ - } STMT_END -#else -#define MBUF_GETINT(x) \ - STMT_START { \ - if ((mptr + sizeof(int)) <= mend) { \ - if (int_aligned(mptr)) \ - x = *(int *) mptr; \ - else \ - memcpy(&x, mptr, sizeof(int)); \ - mptr += sizeof(int); \ - } else \ - return (SV *) 0; \ - } STMT_END -#endif - -#define MBUF_READ(x,s) \ - STMT_START { \ - if ((mptr + (s)) <= mend) { \ - memcpy(x, mptr, s); \ - mptr += s; \ - } else \ - return (SV *) 0; \ - } STMT_END - -#define MBUF_SAFEREAD(x,s,z) \ - STMT_START { \ - if ((mptr + (s)) <= mend) { \ - memcpy(x, mptr, s); \ - mptr += s; \ - } else { \ - sv_free(z); \ - return (SV *) 0; \ - } \ - } STMT_END - -#define MBUF_SAFEPVREAD(x,s,z) \ - STMT_START { \ - if ((mptr + (s)) <= mend) { \ - memcpy(x, mptr, s); \ - mptr += s; \ - } else { \ - Safefree(z); \ - return (SV *) 0; \ - } \ - } STMT_END - -#define MBUF_PUTC(c) \ - STMT_START { \ - if (mptr < mend) \ - *mptr++ = (char) c; \ - else { \ - MBUF_XTEND(1); \ - *mptr++ = (char) c; \ - } \ - } STMT_END - -#ifdef CRAY_HACK -#define MBUF_PUTINT(i) \ - STMT_START { \ - MBUF_CHK(4); \ - memcpy(mptr, oI(&i), 4); \ - mptr += 4; \ - } STMT_END -#else -#define MBUF_PUTINT(i) \ - STMT_START { \ - MBUF_CHK(sizeof(int)); \ - if (int_aligned(mptr)) \ - *(int *) mptr = i; \ - else \ - memcpy(mptr, &i, sizeof(int)); \ - mptr += sizeof(int); \ - } STMT_END -#endif - -#define MBUF_WRITE(x,s) \ - STMT_START { \ - MBUF_CHK(s); \ - memcpy(mptr, x, s); \ - mptr += s; \ - } STMT_END - -/* - * Possible return values for sv_type(). - */ - -#define svis_REF 0 -#define svis_SCALAR 1 -#define svis_ARRAY 2 -#define svis_HASH 3 -#define svis_TIED 4 -#define svis_TIED_ITEM 5 -#define svis_CODE 6 -#define svis_OTHER 7 - -/* - * Flags for SX_HOOK. - */ - -#define SHF_TYPE_MASK 0x03 -#define SHF_LARGE_CLASSLEN 0x04 -#define SHF_LARGE_STRLEN 0x08 -#define SHF_LARGE_LISTLEN 0x10 -#define SHF_IDX_CLASSNAME 0x20 -#define SHF_NEED_RECURSE 0x40 -#define SHF_HAS_LIST 0x80 - -/* - * Types for SX_HOOK (last 2 bits in flags). - */ - -#define SHT_SCALAR 0 -#define SHT_ARRAY 1 -#define SHT_HASH 2 -#define SHT_EXTRA 3 /* Read extra byte for type */ - -/* - * The following are held in the "extra byte"... - */ - -#define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */ -#define SHT_TARRAY 5 /* 4 + 1 -- tied array */ -#define SHT_THASH 6 /* 4 + 2 -- tied hash */ - -/* - * per hash flags for flagged hashes - */ - -#define SHV_RESTRICTED 0x01 - -/* - * per key flags for flagged hashes - */ - -#define SHV_K_UTF8 0x01 -#define SHV_K_WASUTF8 0x02 -#define SHV_K_LOCKED 0x04 -#define SHV_K_ISSV 0x08 -#define SHV_K_PLACEHOLDER 0x10 - -/* - * Before 0.6, the magic string was "perl-store" (binary version number 0). - * - * Since 0.6 introduced many binary incompatibilities, the magic string has - * been changed to "pst0" to allow an old image to be properly retrieved by - * a newer Storable, but ensure a newer image cannot be retrieved with an - * older version. - * - * At 0.7, objects are given the ability to serialize themselves, and the - * set of markers is extended, backward compatibility is not jeopardized, - * so the binary version number could have remained unchanged. To correctly - * spot errors if a file making use of 0.7-specific extensions is given to - * 0.6 for retrieval, the binary version was moved to "2". And I'm introducing - * a "minor" version, to better track this kind of evolution from now on. - * - */ -static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ -static const char magicstr[] = "pst0"; /* Used as a magic number */ - -#define MAGICSTR_BYTES 'p','s','t','0' -#define OLDMAGICSTR_BYTES 'p','e','r','l','-','s','t','o','r','e' - -/* 5.6.x introduced the ability to have IVs as long long. - However, Configure still defined BYTEORDER based on the size of a long. - Storable uses the BYTEORDER value as part of the header, but doesn't - explicity store sizeof(IV) anywhere in the header. Hence on 5.6.x built - with IV as long long on a platform that uses Configure (ie most things - except VMS and Windows) headers are identical for the different IV sizes, - despite the files containing some fields based on sizeof(IV) - Erk. Broken-ness. - 5.8 is consistent - the following redifinition kludge is only needed on - 5.6.x, but the interwork is needed on 5.8 while data survives in files - with the 5.6 header. - -*/ - -#if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4) -#ifndef NO_56_INTERWORK_KLUDGE -#define USE_56_INTERWORK_KLUDGE -#endif -#if BYTEORDER == 0x1234 -#undef BYTEORDER -#define BYTEORDER 0x12345678 -#else -#if BYTEORDER == 0x4321 -#undef BYTEORDER -#define BYTEORDER 0x87654321 -#endif -#endif -#endif - -#if BYTEORDER == 0x1234 -#define BYTEORDER_BYTES '1','2','3','4' -#else -#if BYTEORDER == 0x12345678 -#define BYTEORDER_BYTES '1','2','3','4','5','6','7','8' -#ifdef USE_56_INTERWORK_KLUDGE -#define BYTEORDER_BYTES_56 '1','2','3','4' -#endif -#else -#if BYTEORDER == 0x87654321 -#define BYTEORDER_BYTES '8','7','6','5','4','3','2','1' -#ifdef USE_56_INTERWORK_KLUDGE -#define BYTEORDER_BYTES_56 '4','3','2','1' -#endif -#else -#if BYTEORDER == 0x4321 -#define BYTEORDER_BYTES '4','3','2','1' -#else -#error Unknown byteorder. Please append your byteorder to Storable.xs -#endif -#endif -#endif -#endif - -static const char byteorderstr[] = {BYTEORDER_BYTES, 0}; -#ifdef USE_56_INTERWORK_KLUDGE -static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; -#endif - -#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ -#define STORABLE_BIN_MINOR 7 /* Binary minor "version" */ - -#if (PATCHLEVEL <= 5) -#define STORABLE_BIN_WRITE_MINOR 4 -#else -/* - * Perl 5.6.0 onwards can do weak references. -*/ -#define STORABLE_BIN_WRITE_MINOR 7 -#endif /* (PATCHLEVEL <= 5) */ - -#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1)) -#define PL_sv_placeholder PL_sv_undef -#endif - -/* - * Useful store shortcuts... - */ - -/* - * Note that if you put more than one mark for storing a particular - * type of thing, *and* in the retrieve_foo() function you mark both - * the thingy's you get off with SEEN(), you *must* increase the - * tagnum with cxt->tagnum++ along with this macro! - * - samv 20Jan04 - */ -#define PUTMARK(x) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_PUTC(x); \ - else if (PerlIO_putc(cxt->fio, x) == EOF) \ - return -1; \ - } STMT_END - -#define WRITE_I32(x) \ - STMT_START { \ - ASSERT(sizeof(x) == sizeof(I32), ("writing an I32")); \ - if (!cxt->fio) \ - MBUF_PUTINT(x); \ - else if (PerlIO_write(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ - return -1; \ - } STMT_END - -#ifdef HAS_HTONL -#define WLEN(x) \ - STMT_START { \ - if (cxt->netorder) { \ - int y = (int) htonl(x); \ - if (!cxt->fio) \ - MBUF_PUTINT(y); \ - else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \ - return -1; \ - } else { \ - if (!cxt->fio) \ - MBUF_PUTINT(x); \ - else if (PerlIO_write(cxt->fio,oI(&x),oS(sizeof(x))) != oS(sizeof(x))) \ - return -1; \ - } \ - } STMT_END -#else -#define WLEN(x) WRITE_I32(x) -#endif - -#define WRITE(x,y) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_WRITE(x,y); \ - else if (PerlIO_write(cxt->fio, x, y) != y) \ - return -1; \ - } STMT_END - -#define STORE_PV_LEN(pv, len, small, large) \ - STMT_START { \ - if (len <= LG_SCALAR) { \ - unsigned char clen = (unsigned char) len; \ - PUTMARK(small); \ - PUTMARK(clen); \ - if (len) \ - WRITE(pv, len); \ - } else { \ - PUTMARK(large); \ - WLEN(len); \ - WRITE(pv, len); \ - } \ - } STMT_END - -#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR) - -/* - * Store &PL_sv_undef in arrays without recursing through store(). - */ -#define STORE_SV_UNDEF() \ - STMT_START { \ - cxt->tagnum++; \ - PUTMARK(SX_SV_UNDEF); \ - } STMT_END - -/* - * Useful retrieve shortcuts... - */ - -#define GETCHAR() \ - (cxt->fio ? PerlIO_getc(cxt->fio) : (mptr >= mend ? EOF : (int) *mptr++)) - -#define GETMARK(x) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_GETC(x); \ - else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \ - return (SV *) 0; \ - } STMT_END - -#define READ_I32(x) \ - STMT_START { \ - ASSERT(sizeof(x) == sizeof(I32), ("reading an I32")); \ - oC(x); \ - if (!cxt->fio) \ - MBUF_GETINT(x); \ - else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ - return (SV *) 0; \ - } STMT_END - -#ifdef HAS_NTOHL -#define RLEN(x) \ - STMT_START { \ - oC(x); \ - if (!cxt->fio) \ - MBUF_GETINT(x); \ - else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ - return (SV *) 0; \ - if (cxt->netorder) \ - x = (int) ntohl(x); \ - } STMT_END -#else -#define RLEN(x) READ_I32(x) -#endif - -#define READ(x,y) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_READ(x, y); \ - else if (PerlIO_read(cxt->fio, x, y) != y) \ - return (SV *) 0; \ - } STMT_END - -#define SAFEREAD(x,y,z) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_SAFEREAD(x,y,z); \ - else if (PerlIO_read(cxt->fio, x, y) != y) { \ - sv_free(z); \ - return (SV *) 0; \ - } \ - } STMT_END - -#define SAFEPVREAD(x,y,z) \ - STMT_START { \ - if (!cxt->fio) \ - MBUF_SAFEPVREAD(x,y,z); \ - else if (PerlIO_read(cxt->fio, x, y) != y) { \ - Safefree(z); \ - return (SV *) 0; \ - } \ - } STMT_END - -/* - * This macro is used at retrieve time, to remember where object 'y', bearing a - * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker, - * we'll therefore know where it has been retrieved and will be able to - * share the same reference, as in the original stored memory image. - * - * We also need to bless objects ASAP for hooks (which may compute "ref $x" - * on the objects given to STORABLE_thaw and expect that to be defined), and - * also for overloaded objects (for which we might not find the stash if the - * object is not blessed yet--this might occur for overloaded objects that - * refer to themselves indirectly: if we blessed upon return from a sub - * retrieve(), the SX_OBJECT marker we'd found could not have overloading - * restored on it because the underlying object would not be blessed yet!). - * - * To achieve that, the class name of the last retrieved object is passed down - * recursively, and the first SEEN() call for which the class name is not NULL - * will bless the object. - * - * i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef) - */ -#define SEEN(y,c,i) \ - STMT_START { \ - if (!y) \ - return (SV *) 0; \ - if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) : SvREFCNT_inc(y)) == 0) \ - return (SV *) 0; \ - TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \ - PTR2UV(y), SvREFCNT(y)-1)); \ - if (c) \ - BLESS((SV *) (y), c); \ - } STMT_END - -/* - * Bless `s' in `p', via a temporary reference, required by sv_bless(). - */ -#define BLESS(s,p) \ - STMT_START { \ - SV *ref; \ - HV *stash; \ - TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \ - stash = gv_stashpv((p), GV_ADD); \ - ref = newRV_noinc(s); \ - (void) sv_bless(ref, stash); \ - SvRV_set(ref, NULL); \ - SvREFCNT_dec(ref); \ - } STMT_END -/* - * sort (used in store_hash) - conditionally use qsort when - * sortsv is not available ( <= 5.6.1 ). - */ - -#if (PATCHLEVEL <= 6) - -#if defined(USE_ITHREADS) - -#define STORE_HASH_SORT \ - ENTER; { \ - PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \ - SAVESPTR(orig_perl); \ - PERL_SET_CONTEXT(aTHX); \ - qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); \ - } LEAVE; - -#else /* ! USE_ITHREADS */ - -#define STORE_HASH_SORT \ - qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); - -#endif /* USE_ITHREADS */ - -#else /* PATCHLEVEL > 6 */ - -#define STORE_HASH_SORT \ - sortsv(AvARRAY(av), len, Perl_sv_cmp); - -#endif /* PATCHLEVEL <= 6 */ - -static int store(pTHX_ stcxt_t *cxt, SV *sv); -static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname); - -/* - * Dynamic dispatching table for SV store. - */ - -static int store_ref(pTHX_ stcxt_t *cxt, SV *sv); -static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv); -static int store_array(pTHX_ stcxt_t *cxt, AV *av); -static int store_hash(pTHX_ stcxt_t *cxt, HV *hv); -static int store_tied(pTHX_ stcxt_t *cxt, SV *sv); -static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv); -static int store_code(pTHX_ stcxt_t *cxt, CV *cv); -static int store_other(pTHX_ stcxt_t *cxt, SV *sv); -static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg); - -typedef int (*sv_store_t)(pTHX_ stcxt_t *cxt, SV *sv); - -static const sv_store_t sv_store[] = { - (sv_store_t)store_ref, /* svis_REF */ - (sv_store_t)store_scalar, /* svis_SCALAR */ - (sv_store_t)store_array, /* svis_ARRAY */ - (sv_store_t)store_hash, /* svis_HASH */ - (sv_store_t)store_tied, /* svis_TIED */ - (sv_store_t)store_tied_item, /* svis_TIED_ITEM */ - (sv_store_t)store_code, /* svis_CODE */ - (sv_store_t)store_other, /* svis_OTHER */ -}; - -#define SV_STORE(x) (*sv_store[x]) - -/* - * Dynamic dispatching tables for SV retrieval. - */ - -static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname); -static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname); -static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname); - -typedef SV* (*sv_retrieve_t)(pTHX_ stcxt_t *cxt, const char *name); - -static const sv_retrieve_t sv_old_retrieve[] = { - 0, /* SX_OBJECT -- entry unused dynamically */ - (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ - (sv_retrieve_t)old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ - (sv_retrieve_t)old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */ - (sv_retrieve_t)retrieve_ref, /* SX_REF */ - (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ - (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ - (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ - (sv_retrieve_t)retrieve_byte, /* SX_BYTE */ - (sv_retrieve_t)retrieve_netint, /* SX_NETINT */ - (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ - (sv_retrieve_t)retrieve_tied_array, /* SX_ARRAY */ - (sv_retrieve_t)retrieve_tied_hash, /* SX_HASH */ - (sv_retrieve_t)retrieve_tied_scalar, /* SX_SCALAR */ - (sv_retrieve_t)retrieve_other, /* SX_SV_UNDEF not supported */ - (sv_retrieve_t)retrieve_other, /* SX_SV_YES not supported */ - (sv_retrieve_t)retrieve_other, /* SX_SV_NO not supported */ - (sv_retrieve_t)retrieve_other, /* SX_BLESS not supported */ - (sv_retrieve_t)retrieve_other, /* SX_IX_BLESS not supported */ - (sv_retrieve_t)retrieve_other, /* SX_HOOK not supported */ - (sv_retrieve_t)retrieve_other, /* SX_OVERLOADED not supported */ - (sv_retrieve_t)retrieve_other, /* SX_TIED_KEY not supported */ - (sv_retrieve_t)retrieve_other, /* SX_TIED_IDX not supported */ - (sv_retrieve_t)retrieve_other, /* SX_UTF8STR not supported */ - (sv_retrieve_t)retrieve_other, /* SX_LUTF8STR not supported */ - (sv_retrieve_t)retrieve_other, /* SX_FLAG_HASH not supported */ - (sv_retrieve_t)retrieve_other, /* SX_CODE not supported */ - (sv_retrieve_t)retrieve_other, /* SX_WEAKREF not supported */ - (sv_retrieve_t)retrieve_other, /* SX_WEAKOVERLOAD not supported */ - (sv_retrieve_t)retrieve_other, /* SX_ERROR */ -}; - -static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname); -static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname); - -static const sv_retrieve_t sv_retrieve[] = { - 0, /* SX_OBJECT -- entry unused dynamically */ - (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ - (sv_retrieve_t)retrieve_array, /* SX_ARRAY */ - (sv_retrieve_t)retrieve_hash, /* SX_HASH */ - (sv_retrieve_t)retrieve_ref, /* SX_REF */ - (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ - (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ - (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ - (sv_retrieve_t)retrieve_byte, /* SX_BYTE */ - (sv_retrieve_t)retrieve_netint, /* SX_NETINT */ - (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ - (sv_retrieve_t)retrieve_tied_array, /* SX_ARRAY */ - (sv_retrieve_t)retrieve_tied_hash, /* SX_HASH */ - (sv_retrieve_t)retrieve_tied_scalar, /* SX_SCALAR */ - (sv_retrieve_t)retrieve_sv_undef, /* SX_SV_UNDEF */ - (sv_retrieve_t)retrieve_sv_yes, /* SX_SV_YES */ - (sv_retrieve_t)retrieve_sv_no, /* SX_SV_NO */ - (sv_retrieve_t)retrieve_blessed, /* SX_BLESS */ - (sv_retrieve_t)retrieve_idx_blessed, /* SX_IX_BLESS */ - (sv_retrieve_t)retrieve_hook, /* SX_HOOK */ - (sv_retrieve_t)retrieve_overloaded, /* SX_OVERLOAD */ - (sv_retrieve_t)retrieve_tied_key, /* SX_TIED_KEY */ - (sv_retrieve_t)retrieve_tied_idx, /* SX_TIED_IDX */ - (sv_retrieve_t)retrieve_utf8str, /* SX_UTF8STR */ - (sv_retrieve_t)retrieve_lutf8str, /* SX_LUTF8STR */ - (sv_retrieve_t)retrieve_flag_hash, /* SX_HASH */ - (sv_retrieve_t)retrieve_code, /* SX_CODE */ - (sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */ - (sv_retrieve_t)retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */ - (sv_retrieve_t)retrieve_other, /* SX_ERROR */ -}; - -#define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)]) - -static SV *mbuf2sv(pTHX); - -/*** - *** Context management. - ***/ - -/* - * init_perinterp - * - * Called once per "thread" (interpreter) to initialize some global context. - */ -static void init_perinterp(pTHX) -{ - INIT_STCXT; - - cxt->netorder = 0; /* true if network order used */ - cxt->forgive_me = -1; /* whether to be forgiving... */ - cxt->accept_future_minor = -1; /* would otherwise occur too late */ -} - -/* - * reset_context - * - * Called at the end of every context cleaning, to perform common reset - * operations. - */ -static void reset_context(stcxt_t *cxt) -{ - cxt->entry = 0; - cxt->s_dirty = 0; - cxt->optype &= ~(ST_STORE|ST_RETRIEVE); /* Leave ST_CLONE alone */ -} - -/* - * init_store_context - * - * Initialize a new store context for real recursion. - */ -static void init_store_context( - pTHX_ - stcxt_t *cxt, - PerlIO *f, - int optype, - int network_order) -{ - TRACEME(("init_store_context")); - - cxt->netorder = network_order; - cxt->forgive_me = -1; /* Fetched from perl if needed */ - cxt->deparse = -1; /* Idem */ - cxt->eval = NULL; /* Idem */ - cxt->canonical = -1; /* Idem */ - cxt->tagnum = -1; /* Reset tag numbers */ - cxt->classnum = -1; /* Reset class numbers */ - cxt->fio = f; /* Where I/O are performed */ - cxt->optype = optype; /* A store, or a deep clone */ - cxt->entry = 1; /* No recursion yet */ - - /* - * The `hseen' table is used to keep track of each SV stored and their - * associated tag numbers is special. It is "abused" because the - * values stored are not real SV, just integers cast to (SV *), - * which explains the freeing below. - * - * It is also one possible bottlneck to achieve good storing speed, - * so the "shared keys" optimization is turned off (unlikely to be - * of any use here), and the hash table is "pre-extended". Together, - * those optimizations increase the throughput by 12%. - */ - -#ifdef USE_PTR_TABLE - cxt->pseen = ptr_table_new(); - cxt->hseen = 0; -#else - cxt->hseen = newHV(); /* Table where seen objects are stored */ - HvSHAREKEYS_off(cxt->hseen); -#endif - /* - * The following does not work well with perl5.004_04, and causes - * a core dump later on, in a completely unrelated spot, which - * makes me think there is a memory corruption going on. - * - * Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking - * it below does not make any difference. It seems to work fine - * with perl5.004_68 but given the probable nature of the bug, - * that does not prove anything. - * - * It's a shame because increasing the amount of buckets raises - * store() throughput by 5%, but until I figure this out, I can't - * allow for this to go into production. - * - * It is reported fixed in 5.005, hence the #if. - */ -#if PERL_VERSION >= 5 -#define HBUCKETS 4096 /* Buckets for %hseen */ -#ifndef USE_PTR_TABLE - HvMAX(cxt->hseen) = HBUCKETS - 1; /* keys %hseen = $HBUCKETS; */ -#endif -#endif - - /* - * The `hclass' hash uses the same settings as `hseen' above, but it is - * used to assign sequential tags (numbers) to class names for blessed - * objects. - * - * We turn the shared key optimization on. - */ - - cxt->hclass = newHV(); /* Where seen classnames are stored */ - -#if PERL_VERSION >= 5 - HvMAX(cxt->hclass) = HBUCKETS - 1; /* keys %hclass = $HBUCKETS; */ -#endif - - /* - * The `hook' hash table is used to keep track of the references on - * the STORABLE_freeze hook routines, when found in some class name. - * - * It is assumed that the inheritance tree will not be changed during - * storing, and that no new method will be dynamically created by the - * hooks. - */ - - cxt->hook = newHV(); /* Table where hooks are cached */ - - /* - * The `hook_seen' array keeps track of all the SVs returned by - * STORABLE_freeze hooks for us to serialize, so that they are not - * reclaimed until the end of the serialization process. Each SV is - * only stored once, the first time it is seen. - */ - - cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */ -} - -/* - * clean_store_context - * - * Clean store context by - */ -static void clean_store_context(pTHX_ stcxt_t *cxt) -{ - HE *he; - - TRACEME(("clean_store_context")); - - ASSERT(cxt->optype & ST_STORE, ("was performing a store()")); - - /* - * Insert real values into hashes where we stored faked pointers. - */ - -#ifndef USE_PTR_TABLE - if (cxt->hseen) { - hv_iterinit(cxt->hseen); - while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall, grr.. */ - HeVAL(he) = &PL_sv_undef; - } -#endif - - if (cxt->hclass) { - hv_iterinit(cxt->hclass); - while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall, grr.. */ - HeVAL(he) = &PL_sv_undef; - } - - /* - * And now dispose of them... - * - * The surrounding if() protection has been added because there might be - * some cases where this routine is called more than once, during - * exceptionnal events. This was reported by Marc Lehmann when Storable - * is executed from mod_perl, and the fix was suggested by him. - * -- RAM, 20/12/2000 - */ - -#ifdef USE_PTR_TABLE - if (cxt->pseen) { - struct ptr_tbl *pseen = cxt->pseen; - cxt->pseen = 0; - ptr_table_free(pseen); - } - assert(!cxt->hseen); -#else - if (cxt->hseen) { - HV *hseen = cxt->hseen; - cxt->hseen = 0; - hv_undef(hseen); - sv_free((SV *) hseen); - } -#endif - - if (cxt->hclass) { - HV *hclass = cxt->hclass; - cxt->hclass = 0; - hv_undef(hclass); - sv_free((SV *) hclass); - } - - if (cxt->hook) { - HV *hook = cxt->hook; - cxt->hook = 0; - hv_undef(hook); - sv_free((SV *) hook); - } - - if (cxt->hook_seen) { - AV *hook_seen = cxt->hook_seen; - cxt->hook_seen = 0; - av_undef(hook_seen); - sv_free((SV *) hook_seen); - } - - cxt->forgive_me = -1; /* Fetched from perl if needed */ - cxt->deparse = -1; /* Idem */ - if (cxt->eval) { - SvREFCNT_dec(cxt->eval); - } - cxt->eval = NULL; /* Idem */ - cxt->canonical = -1; /* Idem */ - - reset_context(cxt); -} - -/* - * init_retrieve_context - * - * Initialize a new retrieve context for real recursion. - */ -static void init_retrieve_context(pTHX_ stcxt_t *cxt, int optype, int is_tainted) -{ - TRACEME(("init_retrieve_context")); - - /* - * The hook hash table is used to keep track of the references on - * the STORABLE_thaw hook routines, when found in some class name. - * - * It is assumed that the inheritance tree will not be changed during - * storing, and that no new method will be dynamically created by the - * hooks. - */ - - cxt->hook = newHV(); /* Caches STORABLE_thaw */ - -#ifdef USE_PTR_TABLE - cxt->pseen = 0; -#endif - - /* - * If retrieving an old binary version, the cxt->retrieve_vtbl variable - * was set to sv_old_retrieve. We'll need a hash table to keep track of - * the correspondance between the tags and the tag number used by the - * new retrieve routines. - */ - - cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve) - ? newHV() : 0); - - cxt->aseen = newAV(); /* Where retrieved objects are kept */ - cxt->where_is_undef = -1; /* Special case for PL_sv_undef */ - cxt->aclass = newAV(); /* Where seen classnames are kept */ - cxt->tagnum = 0; /* Have to count objects... */ - cxt->classnum = 0; /* ...and class names as well */ - cxt->optype = optype; - cxt->s_tainted = is_tainted; - cxt->entry = 1; /* No recursion yet */ -#ifndef HAS_RESTRICTED_HASHES - cxt->derestrict = -1; /* Fetched from perl if needed */ -#endif -#ifndef HAS_UTF8_ALL - cxt->use_bytes = -1; /* Fetched from perl if needed */ -#endif - cxt->accept_future_minor = -1; /* Fetched from perl if needed */ -} - -/* - * clean_retrieve_context - * - * Clean retrieve context by - */ -static void clean_retrieve_context(pTHX_ stcxt_t *cxt) -{ - TRACEME(("clean_retrieve_context")); - - ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()")); - - if (cxt->aseen) { - AV *aseen = cxt->aseen; - cxt->aseen = 0; - av_undef(aseen); - sv_free((SV *) aseen); - } - cxt->where_is_undef = -1; - - if (cxt->aclass) { - AV *aclass = cxt->aclass; - cxt->aclass = 0; - av_undef(aclass); - sv_free((SV *) aclass); - } - - if (cxt->hook) { - HV *hook = cxt->hook; - cxt->hook = 0; - hv_undef(hook); - sv_free((SV *) hook); - } - - if (cxt->hseen) { - HV *hseen = cxt->hseen; - cxt->hseen = 0; - hv_undef(hseen); - sv_free((SV *) hseen); /* optional HV, for backward compat. */ - } - -#ifndef HAS_RESTRICTED_HASHES - cxt->derestrict = -1; /* Fetched from perl if needed */ -#endif -#ifndef HAS_UTF8_ALL - cxt->use_bytes = -1; /* Fetched from perl if needed */ -#endif - cxt->accept_future_minor = -1; /* Fetched from perl if needed */ - - reset_context(cxt); -} - -/* - * clean_context - * - * A workaround for the CROAK bug: cleanup the last context. - */ -static void clean_context(pTHX_ stcxt_t *cxt) -{ - TRACEME(("clean_context")); - - ASSERT(cxt->s_dirty, ("dirty context")); - - if (cxt->membuf_ro) - MBUF_RESTORE(); - - ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); - - if (cxt->optype & ST_RETRIEVE) - clean_retrieve_context(aTHX_ cxt); - else if (cxt->optype & ST_STORE) - clean_store_context(aTHX_ cxt); - else - reset_context(cxt); - - ASSERT(!cxt->s_dirty, ("context is clean")); - ASSERT(cxt->entry == 0, ("context is reset")); -} - -/* - * allocate_context - * - * Allocate a new context and push it on top of the parent one. - * This new context is made globally visible via SET_STCXT(). - */ -static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt) -{ - stcxt_t *cxt; - - TRACEME(("allocate_context")); - - ASSERT(!parent_cxt->s_dirty, ("parent context clean")); - - NEW_STORABLE_CXT_OBJ(cxt); - cxt->prev = parent_cxt->my_sv; - SET_STCXT(cxt); - - ASSERT(!cxt->s_dirty, ("clean context")); - - return cxt; -} - -/* - * free_context - * - * Free current context, which cannot be the "root" one. - * Make the context underneath globally visible via SET_STCXT(). - */ -static void free_context(pTHX_ stcxt_t *cxt) -{ - stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0); - - TRACEME(("free_context")); - - ASSERT(!cxt->s_dirty, ("clean context")); - ASSERT(prev, ("not freeing root context")); - - SvREFCNT_dec(cxt->my_sv); - SET_STCXT(prev); - - ASSERT(cxt, ("context not void")); -} - -/*** - *** Predicates. - ***/ - -/* - * is_storing - * - * Tells whether we're in the middle of a store operation. - */ -static int is_storing(pTHX) -{ - dSTCXT; - - return cxt->entry && (cxt->optype & ST_STORE); -} - -/* - * is_retrieving - * - * Tells whether we're in the middle of a retrieve operation. - */ -static int is_retrieving(pTHX) -{ - dSTCXT; - - return cxt->entry && (cxt->optype & ST_RETRIEVE); -} - -/* - * last_op_in_netorder - * - * Returns whether last operation was made using network order. - * - * This is typically out-of-band information that might prove useful - * to people wishing to convert native to network order data when used. - */ -static int last_op_in_netorder(pTHX) -{ - dSTCXT; - - return cxt->netorder; -} - -/*** - *** Hook lookup and calling routines. - ***/ - -/* - * pkg_fetchmeth - * - * A wrapper on gv_fetchmethod_autoload() which caches results. - * - * Returns the routine reference as an SV*, or null if neither the package - * nor its ancestors know about the method. - */ -static SV *pkg_fetchmeth( - pTHX_ - HV *cache, - HV *pkg, - const char *method) -{ - GV *gv; - SV *sv; - const char *hvname = HvNAME_get(pkg); - - - /* - * The following code is the same as the one performed by UNIVERSAL::can - * in the Perl core. - */ - - gv = gv_fetchmethod_autoload(pkg, method, FALSE); - if (gv && isGV(gv)) { - sv = newRV((SV*) GvCV(gv)); - TRACEME(("%s->%s: 0x%"UVxf, hvname, method, PTR2UV(sv))); - } else { - sv = newSVsv(&PL_sv_undef); - TRACEME(("%s->%s: not found", hvname, method)); - } - - /* - * Cache the result, ignoring failure: if we can't store the value, - * it just won't be cached. - */ - - (void) hv_store(cache, hvname, strlen(hvname), sv, 0); - - return SvOK(sv) ? sv : (SV *) 0; -} - -/* - * pkg_hide - * - * Force cached value to be undef: hook ignored even if present. - */ -static void pkg_hide( - pTHX_ - HV *cache, - HV *pkg, - const char *method) -{ - const char *hvname = HvNAME_get(pkg); - (void) hv_store(cache, - hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0); -} - -/* - * pkg_uncache - * - * Discard cached value: a whole fetch loop will be retried at next lookup. - */ -static void pkg_uncache( - pTHX_ - HV *cache, - HV *pkg, - const char *method) -{ - const char *hvname = HvNAME_get(pkg); - (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD); -} - -/* - * pkg_can - * - * Our own "UNIVERSAL::can", which caches results. - * - * Returns the routine reference as an SV*, or null if the object does not - * know about the method. - */ -static SV *pkg_can( - pTHX_ - HV *cache, - HV *pkg, - const char *method) -{ - SV **svh; - SV *sv; - const char *hvname = HvNAME_get(pkg); - - TRACEME(("pkg_can for %s->%s", hvname, method)); - - /* - * Look into the cache to see whether we already have determined - * where the routine was, if any. - * - * NOTA BENE: we don't use `method' at all in our lookup, since we know - * that only one hook (i.e. always the same) is cached in a given cache. - */ - - svh = hv_fetch(cache, hvname, strlen(hvname), FALSE); - if (svh) { - sv = *svh; - if (!SvOK(sv)) { - TRACEME(("cached %s->%s: not found", hvname, method)); - return (SV *) 0; - } else { - TRACEME(("cached %s->%s: 0x%"UVxf, - hvname, method, PTR2UV(sv))); - return sv; - } - } - - TRACEME(("not cached yet")); - return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */ -} - -/* - * scalar_call - * - * Call routine as obj->hook(av) in scalar context. - * Propagates the single returned value if not called in void context. - */ -static SV *scalar_call( - pTHX_ - SV *obj, - SV *hook, - int cloning, - AV *av, - I32 flags) -{ - dSP; - int count; - SV *sv = 0; - - TRACEME(("scalar_call (cloning=%d)", cloning)); - - ENTER; - SAVETMPS; - - PUSHMARK(sp); - XPUSHs(obj); - XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */ - if (av) { - SV **ary = AvARRAY(av); - int cnt = AvFILLp(av) + 1; - int i; - XPUSHs(ary[0]); /* Frozen string */ - for (i = 1; i < cnt; i++) { - TRACEME(("pushing arg #%d (0x%"UVxf")...", - i, PTR2UV(ary[i]))); - XPUSHs(sv_2mortal(newRV(ary[i]))); - } - } - PUTBACK; - - TRACEME(("calling...")); - count = perl_call_sv(hook, flags); /* Go back to Perl code */ - TRACEME(("count = %d", count)); - - SPAGAIN; - - if (count) { - sv = POPs; - SvREFCNT_inc(sv); /* We're returning it, must stay alive! */ - } - - PUTBACK; - FREETMPS; - LEAVE; - - return sv; -} - -/* - * array_call - * - * Call routine obj->hook(cloning) in list context. - * Returns the list of returned values in an array. - */ -static AV *array_call( - pTHX_ - SV *obj, - SV *hook, - int cloning) -{ - dSP; - int count; - AV *av; - int i; - - TRACEME(("array_call (cloning=%d)", cloning)); - - ENTER; - SAVETMPS; - - PUSHMARK(sp); - XPUSHs(obj); /* Target object */ - XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */ - PUTBACK; - - count = perl_call_sv(hook, G_ARRAY); /* Go back to Perl code */ - - SPAGAIN; - - av = newAV(); - for (i = count - 1; i >= 0; i--) { - SV *sv = POPs; - av_store(av, i, SvREFCNT_inc(sv)); - } - - PUTBACK; - FREETMPS; - LEAVE; - - return av; -} - -/* - * known_class - * - * Lookup the class name in the `hclass' table and either assign it a new ID - * or return the existing one, by filling in `classnum'. - * - * Return true if the class was known, false if the ID was just generated. - */ -static int known_class( - pTHX_ - stcxt_t *cxt, - char *name, /* Class name */ - int len, /* Name length */ - I32 *classnum) -{ - SV **svh; - HV *hclass = cxt->hclass; - - TRACEME(("known_class (%s)", name)); - - /* - * Recall that we don't store pointers in this hash table, but tags. - * Therefore, we need LOW_32BITS() to extract the relevant parts. - */ - - svh = hv_fetch(hclass, name, len, FALSE); - if (svh) { - *classnum = LOW_32BITS(*svh); - return TRUE; - } - - /* - * Unknown classname, we need to record it. - */ - - cxt->classnum++; - if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0)) - CROAK(("Unable to record new classname")); - - *classnum = cxt->classnum; - return FALSE; -} - -/*** - *** Sepcific store routines. - ***/ - -/* - * store_ref - * - * Store a reference. - * Layout is SX_REF <object> or SX_OVERLOAD <object>. - */ -static int store_ref(pTHX_ stcxt_t *cxt, SV *sv) -{ - int is_weak = 0; - TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv))); - - /* - * Follow reference, and check if target is overloaded. - */ - -#ifdef SvWEAKREF - if (SvWEAKREF(sv)) - is_weak = 1; - TRACEME(("ref (0x%"UVxf") is%s weak", PTR2UV(sv), is_weak ? "" : "n't")); -#endif - sv = SvRV(sv); - - if (SvOBJECT(sv)) { - HV *stash = (HV *) SvSTASH(sv); - if (stash && Gv_AMG(stash)) { - TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv))); - PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD); - } else - PUTMARK(is_weak ? SX_WEAKREF : SX_REF); - } else - PUTMARK(is_weak ? SX_WEAKREF : SX_REF); - - return store(aTHX_ cxt, sv); -} - -/* - * store_scalar - * - * Store a scalar. - * - * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF. - * The <data> section is omitted if <length> is 0. - * - * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>. - * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>. - */ -static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv) -{ - IV iv; - char *pv; - STRLEN len; - U32 flags = SvFLAGS(sv); /* "cc -O" may put it in register */ - - TRACEME(("store_scalar (0x%"UVxf")", PTR2UV(sv))); - - /* - * For efficiency, break the SV encapsulation by peaking at the flags - * directly without using the Perl macros to avoid dereferencing - * sv->sv_flags each time we wish to check the flags. - */ - - if (!(flags & SVf_OK)) { /* !SvOK(sv) */ - if (sv == &PL_sv_undef) { - TRACEME(("immortal undef")); - PUTMARK(SX_SV_UNDEF); - } else { - TRACEME(("undef at 0x%"UVxf, PTR2UV(sv))); - PUTMARK(SX_UNDEF); - } - return 0; - } - - /* - * Always store the string representation of a scalar if it exists. - * Gisle Aas provided me with this test case, better than a long speach: - * - * perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)' - * SV = PVNV(0x80c8520) - * REFCNT = 1 - * FLAGS = (NOK,POK,pNOK,pPOK) - * IV = 0 - * NV = 0 - * PV = 0x80c83d0 "abc"\0 - * CUR = 3 - * LEN = 4 - * - * Write SX_SCALAR, length, followed by the actual data. - * - * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as - * appropriate, followed by the actual (binary) data. A double - * is written as a string if network order, for portability. - * - * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv). - * The reason is that when the scalar value is tainted, the SvNOK(sv) - * value is false. - * - * The test for a read-only scalar with both POK and NOK set is meant - * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the - * address comparison for each scalar we store. - */ - -#define SV_MAYBE_IMMORTAL (SVf_READONLY|SVf_POK|SVf_NOK) - - if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) { - if (sv == &PL_sv_yes) { - TRACEME(("immortal yes")); - PUTMARK(SX_SV_YES); - } else if (sv == &PL_sv_no) { - TRACEME(("immortal no")); - PUTMARK(SX_SV_NO); - } else { - pv = SvPV(sv, len); /* We know it's SvPOK */ - goto string; /* Share code below */ - } - } else if (flags & SVf_POK) { - /* public string - go direct to string read. */ - goto string_readlen; - } else if ( -#if (PATCHLEVEL <= 6) - /* For 5.6 and earlier NV flag trumps IV flag, so only use integer - direct if NV flag is off. */ - (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK -#else - /* 5.7 rules are that if IV public flag is set, IV value is as - good, if not better, than NV value. */ - flags & SVf_IOK -#endif - ) { - iv = SvIV(sv); - /* - * Will come here from below with iv set if double is an integer. - */ - integer: - - /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ -#ifdef SVf_IVisUV - /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1 - * (for example) and that ends up in the optimised small integer - * case. - */ - if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) { - TRACEME(("large unsigned integer as string, value = %"UVuf, SvUV(sv))); - goto string_readlen; - } -#endif - /* - * Optimize small integers into a single byte, otherwise store as - * a real integer (converted into network order if they asked). - */ - - if (iv >= -128 && iv <= 127) { - unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */ - PUTMARK(SX_BYTE); - PUTMARK(siv); - TRACEME(("small integer stored as %d", siv)); - } else if (cxt->netorder) { -#ifndef HAS_HTONL - TRACEME(("no htonl, fall back to string for integer")); - goto string_readlen; -#else - I32 niv; - - -#if IVSIZE > 4 - if ( -#ifdef SVf_IVisUV - /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ - ((flags & SVf_IVisUV) && SvUV(sv) > 0x7FFFFFFF) || -#endif - (iv > 0x7FFFFFFF) || (iv < -0x80000000)) { - /* Bigger than 32 bits. */ - TRACEME(("large network order integer as string, value = %"IVdf, iv)); - goto string_readlen; - } -#endif - - niv = (I32) htonl((I32) iv); - TRACEME(("using network order")); - PUTMARK(SX_NETINT); - WRITE_I32(niv); -#endif - } else { - PUTMARK(SX_INTEGER); - WRITE(&iv, sizeof(iv)); - } - - TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv)); - } else if (flags & SVf_NOK) { - NV nv; -#if (PATCHLEVEL <= 6) - nv = SvNV(sv); - /* - * Watch for number being an integer in disguise. - */ - if (nv == (NV) (iv = I_V(nv))) { - TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv)); - goto integer; /* Share code above */ - } -#else - - SvIV_please(sv); - if (SvIOK_notUV(sv)) { - iv = SvIV(sv); - goto integer; /* Share code above */ - } - nv = SvNV(sv); -#endif - - if (cxt->netorder) { - TRACEME(("double %"NVff" stored as string", nv)); - goto string_readlen; /* Share code below */ - } - - PUTMARK(SX_DOUBLE); - WRITE(&nv, sizeof(nv)); - - TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv)); - - } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) { - I32 wlen; /* For 64-bit machines */ - - string_readlen: - pv = SvPV(sv, len); - - /* - * Will come here from above if it was readonly, POK and NOK but - * neither &PL_sv_yes nor &PL_sv_no. - */ - string: - - wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */ - if (SvUTF8 (sv)) - STORE_UTF8STR(pv, wlen); - else - STORE_SCALAR(pv, wlen); - TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")", - PTR2UV(sv), SvPVX(sv), (IV)len)); - } else - CROAK(("Can't determine type of %s(0x%"UVxf")", - sv_reftype(sv, FALSE), - PTR2UV(sv))); - return 0; /* Ok, no recursion on scalars */ -} - -/* - * store_array - * - * Store an array. - * - * Layout is SX_ARRAY <size> followed by each item, in increading index order. - * Each item is stored as <object>. - */ -static int store_array(pTHX_ stcxt_t *cxt, AV *av) -{ - SV **sav; - I32 len = av_len(av) + 1; - I32 i; - int ret; - - TRACEME(("store_array (0x%"UVxf")", PTR2UV(av))); - - /* - * Signal array by emitting SX_ARRAY, followed by the array length. - */ - - PUTMARK(SX_ARRAY); - WLEN(len); - TRACEME(("size = %d", len)); - - /* - * Now store each item recursively. - */ - - for (i = 0; i < len; i++) { - sav = av_fetch(av, i, 0); - if (!sav) { - TRACEME(("(#%d) undef item", i)); - STORE_SV_UNDEF(); - continue; - } - TRACEME(("(#%d) item", i)); - if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall, grr... */ - return ret; - } - - TRACEME(("ok (array)")); - - return 0; -} - - -#if (PATCHLEVEL <= 6) - -/* - * sortcmp - * - * Sort two SVs - * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort. - */ -static int -sortcmp(const void *a, const void *b) -{ -#if defined(USE_ITHREADS) - dTHX; -#endif /* USE_ITHREADS */ - return sv_cmp(*(SV * const *) a, *(SV * const *) b); -} - -#endif /* PATCHLEVEL <= 6 */ - -/* - * store_hash - * - * Store a hash table. - * - * For a "normal" hash (not restricted, no utf8 keys): - * - * Layout is SX_HASH <size> followed by each key/value pair, in random order. - * Values are stored as <object>. - * Keys are stored as <length> <data>, the <data> section being omitted - * if length is 0. - * - * For a "fancy" hash (restricted or utf8 keys): - * - * Layout is SX_FLAG_HASH <size> <hash flags> followed by each key/value pair, - * in random order. - * Values are stored as <object>. - * Keys are stored as <flags> <length> <data>, the <data> section being omitted - * if length is 0. - * Currently the only hash flag is "restriced" - * Key flags are as for hv.h - */ -static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) -{ - dVAR; - I32 len = -#ifdef HAS_RESTRICTED_HASHES - HvTOTALKEYS(hv); -#else - HvKEYS(hv); -#endif - I32 i; - int ret = 0; - I32 riter; - HE *eiter; - int flagged_hash = ((SvREADONLY(hv) -#ifdef HAS_HASH_KEY_FLAGS - || HvHASKFLAGS(hv) -#endif - ) ? 1 : 0); - unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0); - - if (flagged_hash) { - /* needs int cast for C++ compilers, doesn't it? */ - TRACEME(("store_hash (0x%"UVxf") (flags %x)", PTR2UV(hv), - (int) hash_flags)); - } else { - TRACEME(("store_hash (0x%"UVxf")", PTR2UV(hv))); - } - - /* - * Signal hash by emitting SX_HASH, followed by the table length. - */ - - if (flagged_hash) { - PUTMARK(SX_FLAG_HASH); - PUTMARK(hash_flags); - } else { - PUTMARK(SX_HASH); - } - WLEN(len); - TRACEME(("size = %d", len)); - - /* - * Save possible iteration state via each() on that table. - */ - - riter = HvRITER_get(hv); - eiter = HvEITER_get(hv); - hv_iterinit(hv); - - /* - * Now store each item recursively. - * - * If canonical is defined to some true value then store each - * key/value pair in sorted order otherwise the order is random. - * Canonical order is irrelevant when a deep clone operation is performed. - * - * Fetch the value from perl only once per store() operation, and only - * when needed. - */ - - if ( - !(cxt->optype & ST_CLONE) && (cxt->canonical == 1 || - (cxt->canonical < 0 && (cxt->canonical = - (SvTRUE(perl_get_sv("Storable::canonical", GV_ADD)) ? 1 : 0)))) - ) { - /* - * Storing in order, sorted by key. - * Run through the hash, building up an array of keys in a - * mortal array, sort the array and then run through the - * array. - */ - - AV *av = newAV(); - - /*av_extend (av, len);*/ - - TRACEME(("using canonical order")); - - for (i = 0; i < len; i++) { -#ifdef HAS_RESTRICTED_HASHES - HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); -#else - HE *he = hv_iternext(hv); -#endif - SV *key; - - if (!he) - CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, len, i)); - key = hv_iterkeysv(he); - av_store(av, AvFILLp(av)+1, key); /* av_push(), really */ - } - - STORE_HASH_SORT; - - for (i = 0; i < len; i++) { -#ifdef HAS_RESTRICTED_HASHES - int placeholders = (int)HvPLACEHOLDERS_get(hv); -#endif - unsigned char flags = 0; - char *keyval; - STRLEN keylen_tmp; - I32 keylen; - SV *key = av_shift(av); - /* This will fail if key is a placeholder. - Track how many placeholders we have, and error if we - "see" too many. */ - HE *he = hv_fetch_ent(hv, key, 0, 0); - SV *val; - - if (he) { - if (!(val = HeVAL(he))) { - /* Internal error, not I/O error */ - return 1; - } - } else { -#ifdef HAS_RESTRICTED_HASHES - /* Should be a placeholder. */ - if (placeholders-- < 0) { - /* This should not happen - number of - retrieves should be identical to - number of placeholders. */ - return 1; - } - /* Value is never needed, and PL_sv_undef is - more space efficient to store. */ - val = &PL_sv_undef; - ASSERT (flags == 0, - ("Flags not 0 but %d", flags)); - flags = SHV_K_PLACEHOLDER; -#else - return 1; -#endif - } - - /* - * Store value first. - */ - - TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val))); - - if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */ - goto out; - - /* - * Write key string. - * Keys are written after values to make sure retrieval - * can be optimal in terms of memory usage, where keys are - * read into a fixed unique buffer called kbuf. - * See retrieve_hash() for details. - */ - - /* Implementation of restricted hashes isn't nicely - abstracted: */ - if ((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) { - flags |= SHV_K_LOCKED; - } - - keyval = SvPV(key, keylen_tmp); - keylen = keylen_tmp; -#ifdef HAS_UTF8_HASHES - /* If you build without optimisation on pre 5.6 - then nothing spots that SvUTF8(key) is always 0, - so the block isn't optimised away, at which point - the linker dislikes the reference to - bytes_from_utf8. */ - if (SvUTF8(key)) { - const char *keysave = keyval; - bool is_utf8 = TRUE; - - /* Just casting the &klen to (STRLEN) won't work - well if STRLEN and I32 are of different widths. - --jhi */ - keyval = (char*)bytes_from_utf8((U8*)keyval, - &keylen_tmp, - &is_utf8); - - /* If we were able to downgrade here, then than - means that we have a key which only had chars - 0-255, but was utf8 encoded. */ - - if (keyval != keysave) { - keylen = keylen_tmp; - flags |= SHV_K_WASUTF8; - } else { - /* keylen_tmp can't have changed, so no need - to assign back to keylen. */ - flags |= SHV_K_UTF8; - } - } -#endif - - if (flagged_hash) { - PUTMARK(flags); - TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval)); - } else { - /* This is a workaround for a bug in 5.8.0 - that causes the HEK_WASUTF8 flag to be - set on an HEK without the hash being - marked as having key flags. We just - cross our fingers and drop the flag. - AMS 20030901 */ - assert (flags == 0 || flags == SHV_K_WASUTF8); - TRACEME(("(#%d) key '%s'", i, keyval)); - } - WLEN(keylen); - if (keylen) - WRITE(keyval, keylen); - if (flags & SHV_K_WASUTF8) - Safefree (keyval); - } - - /* - * Free up the temporary array - */ - - av_undef(av); - sv_free((SV *) av); - - } else { - - /* - * Storing in "random" order (in the order the keys are stored - * within the hash). This is the default and will be faster! - */ - - for (i = 0; i < len; i++) { - char *key = 0; - I32 len; - unsigned char flags; -#ifdef HV_ITERNEXT_WANTPLACEHOLDERS - HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); -#else - HE *he = hv_iternext(hv); -#endif - SV *val = (he ? hv_iterval(hv, he) : 0); - SV *key_sv = NULL; - HEK *hek; - - if (val == 0) - return 1; /* Internal error, not I/O error */ - - /* Implementation of restricted hashes isn't nicely - abstracted: */ - flags - = (((hash_flags & SHV_RESTRICTED) - && SvREADONLY(val)) - ? SHV_K_LOCKED : 0); - - if (val == &PL_sv_placeholder) { - flags |= SHV_K_PLACEHOLDER; - val = &PL_sv_undef; - } - - /* - * Store value first. - */ - - TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val))); - - if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */ - goto out; - - - hek = HeKEY_hek(he); - len = HEK_LEN(hek); - if (len == HEf_SVKEY) { - /* This is somewhat sick, but the internal APIs are - * such that XS code could put one of these in in - * a regular hash. - * Maybe we should be capable of storing one if - * found. - */ - key_sv = HeKEY_sv(he); - flags |= SHV_K_ISSV; - } else { - /* Regular string key. */ -#ifdef HAS_HASH_KEY_FLAGS - if (HEK_UTF8(hek)) - flags |= SHV_K_UTF8; - if (HEK_WASUTF8(hek)) - flags |= SHV_K_WASUTF8; -#endif - key = HEK_KEY(hek); - } - /* - * Write key string. - * Keys are written after values to make sure retrieval - * can be optimal in terms of memory usage, where keys are - * read into a fixed unique buffer called kbuf. - * See retrieve_hash() for details. - */ - - if (flagged_hash) { - PUTMARK(flags); - TRACEME(("(#%d) key '%s' flags %x", i, key, flags)); - } else { - /* This is a workaround for a bug in 5.8.0 - that causes the HEK_WASUTF8 flag to be - set on an HEK without the hash being - marked as having key flags. We just - cross our fingers and drop the flag. - AMS 20030901 */ - assert (flags == 0 || flags == SHV_K_WASUTF8); - TRACEME(("(#%d) key '%s'", i, key)); - } - if (flags & SHV_K_ISSV) { - store(aTHX_ cxt, key_sv); - } else { - WLEN(len); - if (len) - WRITE(key, len); - } - } - } - - TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv))); - -out: - HvRITER_set(hv, riter); /* Restore hash iterator state */ - HvEITER_set(hv, eiter); - - return ret; -} - -/* - * store_code - * - * Store a code reference. - * - * Layout is SX_CODE <length> followed by a scalar containing the perl - * source code of the code reference. - */ -static int store_code(pTHX_ stcxt_t *cxt, CV *cv) -{ -#if PERL_VERSION < 6 - /* - * retrieve_code does not work with perl 5.005 or less - */ - return store_other(aTHX_ cxt, (SV*)cv); -#else - dSP; - I32 len; - int count, reallen; - SV *text, *bdeparse; - - TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv))); - - if ( - cxt->deparse == 0 || - (cxt->deparse < 0 && !(cxt->deparse = - SvTRUE(perl_get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0)) - ) { - return store_other(aTHX_ cxt, (SV*)cv); - } - - /* - * Require B::Deparse. At least B::Deparse 0.61 is needed for - * blessed code references. - */ - /* Ownership of both SVs is passed to load_module, which frees them. */ - load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61)); - SPAGAIN; - - ENTER; - SAVETMPS; - - /* - * create the B::Deparse object - */ - - PUSHMARK(sp); - XPUSHs(sv_2mortal(newSVpvn("B::Deparse",10))); - PUTBACK; - count = call_method("new", G_SCALAR); - SPAGAIN; - if (count != 1) - CROAK(("Unexpected return value from B::Deparse::new\n")); - bdeparse = POPs; - - /* - * call the coderef2text method - */ - - PUSHMARK(sp); - XPUSHs(bdeparse); /* XXX is this already mortal? */ - XPUSHs(sv_2mortal(newRV_inc((SV*)cv))); - PUTBACK; - count = call_method("coderef2text", G_SCALAR); - SPAGAIN; - if (count != 1) - CROAK(("Unexpected return value from B::Deparse::coderef2text\n")); - - text = POPs; - len = SvCUR(text); - reallen = strlen(SvPV_nolen(text)); - - /* - * Empty code references or XS functions are deparsed as - * "(prototype) ;" or ";". - */ - - if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') { - CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n")); - } - - /* - * Signal code by emitting SX_CODE. - */ - - PUTMARK(SX_CODE); - cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */ - TRACEME(("size = %d", len)); - TRACEME(("code = %s", SvPV_nolen(text))); - - /* - * Now store the source code. - */ - - STORE_SCALAR(SvPV_nolen(text), len); - - FREETMPS; - LEAVE; - - TRACEME(("ok (code)")); - - return 0; -#endif -} - -/* - * store_tied - * - * When storing a tied object (be it a tied scalar, array or hash), we lay out - * a special mark, followed by the underlying tied object. For instance, when - * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where - * <hash object> stands for the serialization of the tied hash. - */ -static int store_tied(pTHX_ stcxt_t *cxt, SV *sv) -{ - MAGIC *mg; - SV *obj = NULL; - int ret = 0; - int svt = SvTYPE(sv); - char mtype = 'P'; - - TRACEME(("store_tied (0x%"UVxf")", PTR2UV(sv))); - - /* - * We have a small run-time penalty here because we chose to factorise - * all tieds objects into the same routine, and not have a store_tied_hash, - * a store_tied_array, etc... - * - * Don't use a switch() statement, as most compilers don't optimize that - * well for 2/3 values. An if() else if() cascade is just fine. We put - * tied hashes first, as they are the most likely beasts. - */ - - if (svt == SVt_PVHV) { - TRACEME(("tied hash")); - PUTMARK(SX_TIED_HASH); /* Introduces tied hash */ - } else if (svt == SVt_PVAV) { - TRACEME(("tied array")); - PUTMARK(SX_TIED_ARRAY); /* Introduces tied array */ - } else { - TRACEME(("tied scalar")); - PUTMARK(SX_TIED_SCALAR); /* Introduces tied scalar */ - mtype = 'q'; - } - - if (!(mg = mg_find(sv, mtype))) - CROAK(("No magic '%c' found while storing tied %s", mtype, - (svt == SVt_PVHV) ? "hash" : - (svt == SVt_PVAV) ? "array" : "scalar")); - - /* - * The mg->mg_obj found by mg_find() above actually points to the - * underlying tied Perl object implementation. For instance, if the - * original SV was that of a tied array, then mg->mg_obj is an AV. - * - * Note that we store the Perl object as-is. We don't call its FETCH - * method along the way. At retrieval time, we won't call its STORE - * method either, but the tieing magic will be re-installed. In itself, - * that ensures that the tieing semantics are preserved since futher - * accesses on the retrieved object will indeed call the magic methods... - */ - - /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */ - obj = mg->mg_obj ? mg->mg_obj : newSV(0); - if ((ret = store(aTHX_ cxt, obj))) - return ret; - - TRACEME(("ok (tied)")); - - return 0; -} - -/* - * store_tied_item - * - * Stores a reference to an item within a tied structure: - * - * . \$h{key}, stores both the (tied %h) object and 'key'. - * . \$a[idx], stores both the (tied @a) object and 'idx'. - * - * Layout is therefore either: - * SX_TIED_KEY <object> <key> - * SX_TIED_IDX <object> <index> - */ -static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv) -{ - MAGIC *mg; - int ret; - - TRACEME(("store_tied_item (0x%"UVxf")", PTR2UV(sv))); - - if (!(mg = mg_find(sv, 'p'))) - CROAK(("No magic 'p' found while storing reference to tied item")); - - /* - * We discriminate between \$h{key} and \$a[idx] via mg_ptr. - */ - - if (mg->mg_ptr) { - TRACEME(("store_tied_item: storing a ref to a tied hash item")); - PUTMARK(SX_TIED_KEY); - TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj))); - - if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ - return ret; - - TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr))); - - if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */ - return ret; - } else { - I32 idx = mg->mg_len; - - TRACEME(("store_tied_item: storing a ref to a tied array item ")); - PUTMARK(SX_TIED_IDX); - TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj))); - - if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */ - return ret; - - TRACEME(("store_tied_item: storing IDX %d", idx)); - - WLEN(idx); - } - - TRACEME(("ok (tied item)")); - - return 0; -} - -/* - * store_hook -- dispatched manually, not via sv_store[] - * - * The blessed SV is serialized by a hook. - * - * Simple Layout is: - * - * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>] - * - * where <flags> indicates how long <len>, <len2> and <len3> are, whether - * the trailing part [] is present, the type of object (scalar, array or hash). - * There is also a bit which says how the classname is stored between: - * - * <len> <classname> - * <index> - * - * and when the <index> form is used (classname already seen), the "large - * classname" bit in <flags> indicates how large the <index> is. - * - * The serialized string returned by the hook is of length <len2> and comes - * next. It is an opaque string for us. - * - * Those <len3> object IDs which are listed last represent the extra references - * not directly serialized by the hook, but which are linked to the object. - * - * When recursion is mandated to resolve object-IDs not yet seen, we have - * instead, with <header> being flags with bits set to indicate the object type - * and that recursion was indeed needed: - * - * SX_HOOK <header> <object> <header> <object> <flags> - * - * that same header being repeated between serialized objects obtained through - * recursion, until we reach flags indicating no recursion, at which point - * we know we've resynchronized with a single layout, after <flags>. - * - * When storing a blessed ref to a tied variable, the following format is - * used: - * - * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object> - * - * The first <flags> indication carries an object of type SHT_EXTRA, and the - * real object type is held in the <extra> flag. At the very end of the - * serialization stream, the underlying magic object is serialized, just like - * any other tied variable. - */ -static int store_hook( - pTHX_ - stcxt_t *cxt, - SV *sv, - int type, - HV *pkg, - SV *hook) -{ - I32 len; - char *classname; - STRLEN len2; - SV *ref; - AV *av; - SV **ary; - int count; /* really len3 + 1 */ - unsigned char flags; - char *pv; - int i; - int recursed = 0; /* counts recursion */ - int obj_type; /* object type, on 2 bits */ - I32 classnum; - int ret; - int clone = cxt->optype & ST_CLONE; - char mtype = '\0'; /* for blessed ref to tied structures */ - unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */ - - TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum)); - - /* - * Determine object type on 2 bits. - */ - - switch (type) { - case svis_SCALAR: - obj_type = SHT_SCALAR; - break; - case svis_ARRAY: - obj_type = SHT_ARRAY; - break; - case svis_HASH: - obj_type = SHT_HASH; - break; - case svis_TIED: - /* - * Produced by a blessed ref to a tied data structure, $o in the - * following Perl code. - * - * my %h; - * tie %h, 'FOO'; - * my $o = bless \%h, 'BAR'; - * - * Signal the tie-ing magic by setting the object type as SHT_EXTRA - * (since we have only 2 bits in <flags> to store the type), and an - * <extra> byte flag will be emitted after the FIRST <flags> in the - * stream, carrying what we put in `eflags'. - */ - obj_type = SHT_EXTRA; - switch (SvTYPE(sv)) { - case SVt_PVHV: - eflags = (unsigned char) SHT_THASH; - mtype = 'P'; - break; - case SVt_PVAV: - eflags = (unsigned char) SHT_TARRAY; - mtype = 'P'; - break; - default: - eflags = (unsigned char) SHT_TSCALAR; - mtype = 'q'; - break; - } - break; - default: - CROAK(("Unexpected object type (%d) in store_hook()", type)); - } - flags = SHF_NEED_RECURSE | obj_type; - - classname = HvNAME_get(pkg); - len = strlen(classname); - - /* - * To call the hook, we need to fake a call like: - * - * $object->STORABLE_freeze($cloning); - * - * but we don't have the $object here. For instance, if $object is - * a blessed array, what we have in `sv' is the array, and we can't - * call a method on those. - * - * Therefore, we need to create a temporary reference to the object and - * make the call on that reference. - */ - - TRACEME(("about to call STORABLE_freeze on class %s", classname)); - - ref = newRV_noinc(sv); /* Temporary reference */ - av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */ - SvRV_set(ref, NULL); - SvREFCNT_dec(ref); /* Reclaim temporary reference */ - - count = AvFILLp(av) + 1; - TRACEME(("store_hook, array holds %d items", count)); - - /* - * If they return an empty list, it means they wish to ignore the - * hook for this class (and not just this instance -- that's for them - * to handle if they so wish). - * - * Simply disable the cached entry for the hook (it won't be recomputed - * since it's present in the cache) and recurse to store_blessed(). - */ - - if (!count) { - /* - * They must not change their mind in the middle of a serialization. - */ - - if (hv_fetch(cxt->hclass, classname, len, FALSE)) - CROAK(("Too late to ignore hooks for %s class \"%s\"", - (cxt->optype & ST_CLONE) ? "cloning" : "storing", classname)); - - pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); - - ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible")); - TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname)); - - return store_blessed(aTHX_ cxt, sv, type, pkg); - } - - /* - * Get frozen string. - */ - - ary = AvARRAY(av); - pv = SvPV(ary[0], len2); - /* We can't use pkg_can here because it only caches one method per - * package */ - { - GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE); - if (gv && isGV(gv)) { - if (count > 1) - CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname)); - goto check_done; - } - } - - /* - * If they returned more than one item, we need to serialize some - * extra references if not already done. - * - * Loop over the array, starting at position #1, and for each item, - * ensure it is a reference, serialize it if not already done, and - * replace the entry with the tag ID of the corresponding serialized - * object. - * - * We CHEAT by not calling av_fetch() and read directly within the - * array, for speed. - */ - - for (i = 1; i < count; i++) { -#ifdef USE_PTR_TABLE - char *fake_tag; -#else - SV **svh; -#endif - SV *rsv = ary[i]; - SV *xsv; - SV *tag; - AV *av_hook = cxt->hook_seen; - - if (!SvROK(rsv)) - CROAK(("Item #%d returned by STORABLE_freeze " - "for %s is not a reference", i, classname)); - xsv = SvRV(rsv); /* Follow ref to know what to look for */ - - /* - * Look in hseen and see if we have a tag already. - * Serialize entry if not done already, and get its tag. - */ - -#ifdef USE_PTR_TABLE - /* Fakery needed because ptr_table_fetch returns zero for a - failure, whereas the existing code assumes that it can - safely store a tag zero. So for ptr_tables we store tag+1 - */ - if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv))) - goto sv_seen; /* Avoid moving code too far to the right */ -#else - if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE))) - goto sv_seen; /* Avoid moving code too far to the right */ -#endif - - TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv))); - - /* - * We need to recurse to store that object and get it to be known - * so that we can resolve the list of object-IDs at retrieve time. - * - * The first time we do this, we need to emit the proper header - * indicating that we recursed, and what the type of object is (the - * object we're storing via a user-hook). Indeed, during retrieval, - * we'll have to create the object before recursing to retrieve the - * others, in case those would point back at that object. - */ - - /* [SX_HOOK] <flags> [<extra>] <object>*/ - if (!recursed++) { - PUTMARK(SX_HOOK); - PUTMARK(flags); - if (obj_type == SHT_EXTRA) - PUTMARK(eflags); - } else - PUTMARK(flags); - - if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */ - return ret; - -#ifdef USE_PTR_TABLE - fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv); - if (!sv) - CROAK(("Could not serialize item #%d from hook in %s", i, classname)); -#else - svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE); - if (!svh) - CROAK(("Could not serialize item #%d from hook in %s", i, classname)); -#endif - /* - * It was the first time we serialized `xsv'. - * - * Keep this SV alive until the end of the serialization: if we - * disposed of it right now by decrementing its refcount, and it was - * a temporary value, some next temporary value allocated during - * another STORABLE_freeze might take its place, and we'd wrongly - * assume that new SV was already serialized, based on its presence - * in cxt->hseen. - * - * Therefore, push it away in cxt->hook_seen. - */ - - av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv)); - - sv_seen: - /* - * Dispose of the REF they returned. If we saved the `xsv' away - * in the array of returned SVs, that will not cause the underlying - * referenced SV to be reclaimed. - */ - - ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF")); - SvREFCNT_dec(rsv); /* Dispose of reference */ - - /* - * Replace entry with its tag (not a real SV, so no refcnt increment) - */ - -#ifdef USE_PTR_TABLE - tag = (SV *)--fake_tag; -#else - tag = *svh; -#endif - ary[i] = tag; - TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf, - i-1, PTR2UV(xsv), PTR2UV(tag))); - } - - /* - * Allocate a class ID if not already done. - * - * This needs to be done after the recursion above, since at retrieval - * time, we'll see the inner objects first. Many thanks to - * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and - * proposed the right fix. -- RAM, 15/09/2000 - */ - -check_done: - if (!known_class(aTHX_ cxt, classname, len, &classnum)) { - TRACEME(("first time we see class %s, ID = %d", classname, classnum)); - classnum = -1; /* Mark: we must store classname */ - } else { - TRACEME(("already seen class %s, ID = %d", classname, classnum)); - } - - /* - * Compute leading flags. - */ - - flags = obj_type; - if (((classnum == -1) ? len : classnum) > LG_SCALAR) - flags |= SHF_LARGE_CLASSLEN; - if (classnum != -1) - flags |= SHF_IDX_CLASSNAME; - if (len2 > LG_SCALAR) - flags |= SHF_LARGE_STRLEN; - if (count > 1) - flags |= SHF_HAS_LIST; - if (count > (LG_SCALAR + 1)) - flags |= SHF_LARGE_LISTLEN; - - /* - * We're ready to emit either serialized form: - * - * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>] - * SX_HOOK <flags> <index> <len2> <str> [<len3> <object-IDs>] - * - * If we recursed, the SX_HOOK has already been emitted. - */ - - TRACEME(("SX_HOOK (recursed=%d) flags=0x%x " - "class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d", - recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1)); - - /* SX_HOOK <flags> [<extra>] */ - if (!recursed) { - PUTMARK(SX_HOOK); - PUTMARK(flags); - if (obj_type == SHT_EXTRA) - PUTMARK(eflags); - } else - PUTMARK(flags); - - /* <len> <classname> or <index> */ - if (flags & SHF_IDX_CLASSNAME) { - if (flags & SHF_LARGE_CLASSLEN) - WLEN(classnum); - else { - unsigned char cnum = (unsigned char) classnum; - PUTMARK(cnum); - } - } else { - if (flags & SHF_LARGE_CLASSLEN) - WLEN(len); - else { - unsigned char clen = (unsigned char) len; - PUTMARK(clen); - } - WRITE(classname, len); /* Final \0 is omitted */ - } - - /* <len2> <frozen-str> */ - if (flags & SHF_LARGE_STRLEN) { - I32 wlen2 = len2; /* STRLEN might be 8 bytes */ - WLEN(wlen2); /* Must write an I32 for 64-bit machines */ - } else { - unsigned char clen = (unsigned char) len2; - PUTMARK(clen); - } - if (len2) - WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */ - - /* [<len3> <object-IDs>] */ - if (flags & SHF_HAS_LIST) { - int len3 = count - 1; - if (flags & SHF_LARGE_LISTLEN) - WLEN(len3); - else { - unsigned char clen = (unsigned char) len3; - PUTMARK(clen); - } - - /* - * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a - * real pointer, rather a tag number, well under the 32-bit limit. - */ - - for (i = 1; i < count; i++) { - I32 tagval = htonl(LOW_32BITS(ary[i])); - WRITE_I32(tagval); - TRACEME(("object %d, tag #%d", i-1, ntohl(tagval))); - } - } - - /* - * Free the array. We need extra care for indices after 0, since they - * don't hold real SVs but integers cast. - */ - - if (count > 1) - AvFILLp(av) = 0; /* Cheat, nothing after 0 interests us */ - av_undef(av); - sv_free((SV *) av); - - /* - * If object was tied, need to insert serialization of the magic object. - */ - - if (obj_type == SHT_EXTRA) { - MAGIC *mg; - - if (!(mg = mg_find(sv, mtype))) { - int svt = SvTYPE(sv); - CROAK(("No magic '%c' found while storing ref to tied %s with hook", - mtype, (svt == SVt_PVHV) ? "hash" : - (svt == SVt_PVAV) ? "array" : "scalar")); - } - - TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf, - PTR2UV(mg->mg_obj), PTR2UV(sv))); - - /* - * [<magic object>] - */ - - if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ - return ret; - } - - return 0; -} - -/* - * store_blessed -- dispatched manually, not via sv_store[] - * - * Check whether there is a STORABLE_xxx hook defined in the class or in one - * of its ancestors. If there is, then redispatch to store_hook(); - * - * Otherwise, the blessed SV is stored using the following layout: - * - * SX_BLESS <flag> <len> <classname> <object> - * - * where <flag> indicates whether <len> is stored on 0 or 4 bytes, depending - * on the high-order bit in flag: if 1, then length follows on 4 bytes. - * Otherwise, the low order bits give the length, thereby giving a compact - * representation for class names less than 127 chars long. - * - * Each <classname> seen is remembered and indexed, so that the next time - * an object in the blessed in the same <classname> is stored, the following - * will be emitted: - * - * SX_IX_BLESS <flag> <index> <object> - * - * where <index> is the classname index, stored on 0 or 4 bytes depending - * on the high-order bit in flag (same encoding as above for <len>). - */ -static int store_blessed( - pTHX_ - stcxt_t *cxt, - SV *sv, - int type, - HV *pkg) -{ - SV *hook; - I32 len; - char *classname; - I32 classnum; - - TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg))); - - /* - * Look for a hook for this blessed SV and redirect to store_hook() - * if needed. - */ - - hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); - if (hook) - return store_hook(aTHX_ cxt, sv, type, pkg, hook); - - /* - * This is a blessed SV without any serialization hook. - */ - - classname = HvNAME_get(pkg); - len = strlen(classname); - - TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d", - PTR2UV(sv), classname, cxt->tagnum)); - - /* - * Determine whether it is the first time we see that class name (in which - * case it will be stored in the SX_BLESS form), or whether we already - * saw that class name before (in which case the SX_IX_BLESS form will be - * used). - */ - - if (known_class(aTHX_ cxt, classname, len, &classnum)) { - TRACEME(("already seen class %s, ID = %d", classname, classnum)); - PUTMARK(SX_IX_BLESS); - if (classnum <= LG_BLESS) { - unsigned char cnum = (unsigned char) classnum; - PUTMARK(cnum); - } else { - unsigned char flag = (unsigned char) 0x80; - PUTMARK(flag); - WLEN(classnum); - } - } else { - TRACEME(("first time we see class %s, ID = %d", classname, classnum)); - PUTMARK(SX_BLESS); - if (len <= LG_BLESS) { - unsigned char clen = (unsigned char) len; - PUTMARK(clen); - } else { - unsigned char flag = (unsigned char) 0x80; - PUTMARK(flag); - WLEN(len); /* Don't BER-encode, this should be rare */ - } - WRITE(classname, len); /* Final \0 is omitted */ - } - - /* - * Now emit the <object> part. - */ - - return SV_STORE(type)(aTHX_ cxt, sv); -} - -/* - * store_other - * - * We don't know how to store the item we reached, so return an error condition. - * (it's probably a GLOB, some CODE reference, etc...) - * - * If they defined the `forgive_me' variable at the Perl level to some - * true value, then don't croak, just warn, and store a placeholder string - * instead. - */ -static int store_other(pTHX_ stcxt_t *cxt, SV *sv) -{ - I32 len; - char buf[80]; - - TRACEME(("store_other")); - - /* - * Fetch the value from perl only once per store() operation. - */ - - if ( - cxt->forgive_me == 0 || - (cxt->forgive_me < 0 && !(cxt->forgive_me = - SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0)) - ) - CROAK(("Can't store %s items", sv_reftype(sv, FALSE))); - - warn("Can't store item %s(0x%"UVxf")", - sv_reftype(sv, FALSE), PTR2UV(sv)); - - /* - * Store placeholder string as a scalar instead... - */ - - (void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE), - PTR2UV(sv), (char) 0); - - len = strlen(buf); - STORE_SCALAR(buf, len); - TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, (IV) len)); - - return 0; -} - -/*** - *** Store driving routines - ***/ - -/* - * sv_type - * - * WARNING: partially duplicates Perl's sv_reftype for speed. - * - * Returns the type of the SV, identified by an integer. That integer - * may then be used to index the dynamic routine dispatch table. - */ -static int sv_type(pTHX_ SV *sv) -{ - switch (SvTYPE(sv)) { - case SVt_NULL: -#if PERL_VERSION <= 10 - case SVt_IV: -#endif - case SVt_NV: - /* - * No need to check for ROK, that can't be set here since there - * is no field capable of hodling the xrv_rv reference. - */ - return svis_SCALAR; - case SVt_PV: -#if PERL_VERSION <= 10 - case SVt_RV: -#else - case SVt_IV: -#endif - case SVt_PVIV: - case SVt_PVNV: - /* - * Starting from SVt_PV, it is possible to have the ROK flag - * set, the pointer to the other SV being either stored in - * the xrv_rv (in the case of a pure SVt_RV), or as the - * xpv_pv field of an SVt_PV and its heirs. - * - * However, those SV cannot be magical or they would be an - * SVt_PVMG at least. - */ - return SvROK(sv) ? svis_REF : svis_SCALAR; - case SVt_PVMG: - case SVt_PVLV: /* Workaround for perl5.004_04 "LVALUE" bug */ - if (SvRMAGICAL(sv) && (mg_find(sv, 'p'))) - return svis_TIED_ITEM; - /* FALL THROUGH */ -#if PERL_VERSION < 9 - case SVt_PVBM: -#endif - if (SvRMAGICAL(sv) && (mg_find(sv, 'q'))) - return svis_TIED; - return SvROK(sv) ? svis_REF : svis_SCALAR; - case SVt_PVAV: - if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) - return svis_TIED; - return svis_ARRAY; - case SVt_PVHV: - if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) - return svis_TIED; - return svis_HASH; - case SVt_PVCV: - return svis_CODE; -#if PERL_VERSION > 8 - /* case SVt_BIND: */ -#endif - default: - break; - } - - return svis_OTHER; -} - -/* - * store - * - * Recursively store objects pointed to by the sv to the specified file. - * - * Layout is <content> or SX_OBJECT <tagnum> if we reach an already stored - * object (one for which storage has started -- it may not be over if we have - * a self-referenced structure). This data set forms a stored <object>. - */ -static int store(pTHX_ stcxt_t *cxt, SV *sv) -{ - SV **svh; - int ret; - int type; -#ifdef USE_PTR_TABLE - struct ptr_tbl *pseen = cxt->pseen; -#else - HV *hseen = cxt->hseen; -#endif - - TRACEME(("store (0x%"UVxf")", PTR2UV(sv))); - - /* - * If object has already been stored, do not duplicate data. - * Simply emit the SX_OBJECT marker followed by its tag data. - * The tag is always written in network order. - * - * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a - * real pointer, rather a tag number (watch the insertion code below). - * That means it probably safe to assume it is well under the 32-bit limit, - * and makes the truncation safe. - * -- RAM, 14/09/1999 - */ - -#ifdef USE_PTR_TABLE - svh = (SV **)ptr_table_fetch(pseen, sv); -#else - svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE); -#endif - if (svh) { - I32 tagval; - - if (sv == &PL_sv_undef) { - /* We have seen PL_sv_undef before, but fake it as - if we have not. - - Not the simplest solution to making restricted - hashes work on 5.8.0, but it does mean that - repeated references to the one true undef will - take up less space in the output file. - */ - /* Need to jump past the next hv_store, because on the - second store of undef the old hash value will be - SvREFCNT_dec()ed, and as Storable cheats horribly - by storing non-SVs in the hash a SEGV will ensure. - Need to increase the tag number so that the - receiver has no idea what games we're up to. This - special casing doesn't affect hooks that store - undef, as the hook routine does its own lookup into - hseen. Also this means that any references back - to PL_sv_undef (from the pathological case of hooks - storing references to it) will find the seen hash - entry for the first time, as if we didn't have this - hackery here. (That hseen lookup works even on 5.8.0 - because it's a key of &PL_sv_undef and a value - which is a tag number, not a value which is - PL_sv_undef.) */ - cxt->tagnum++; - type = svis_SCALAR; - goto undef_special_case; - } - -#ifdef USE_PTR_TABLE - tagval = htonl(LOW_32BITS(((char *)svh)-1)); -#else - tagval = htonl(LOW_32BITS(*svh)); -#endif - - TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval))); - - PUTMARK(SX_OBJECT); - WRITE_I32(tagval); - return 0; - } - - /* - * Allocate a new tag and associate it with the address of the sv being - * stored, before recursing... - * - * In order to avoid creating new SvIVs to hold the tagnum we just - * cast the tagnum to an SV pointer and store that in the hash. This - * means that we must clean up the hash manually afterwards, but gives - * us a 15% throughput increase. - * - */ - - cxt->tagnum++; -#ifdef USE_PTR_TABLE - ptr_table_store(pseen, sv, INT2PTR(SV*, 1 + cxt->tagnum)); -#else - if (!hv_store(hseen, - (char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0)) - return -1; -#endif - - /* - * Store `sv' and everything beneath it, using appropriate routine. - * Abort immediately if we get a non-zero status back. - */ - - type = sv_type(aTHX_ sv); - -undef_special_case: - TRACEME(("storing 0x%"UVxf" tag #%d, type %d...", - PTR2UV(sv), cxt->tagnum, type)); - - if (SvOBJECT(sv)) { - HV *pkg = SvSTASH(sv); - ret = store_blessed(aTHX_ cxt, sv, type, pkg); - } else - ret = SV_STORE(type)(aTHX_ cxt, sv); - - TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)", - ret ? "FAILED" : "ok", PTR2UV(sv), - SvREFCNT(sv), sv_reftype(sv, FALSE))); - - return ret; -} - -/* - * magic_write - * - * Write magic number and system information into the file. - * Layout is <magic> <network> [<len> <byteorder> <sizeof int> <sizeof long> - * <sizeof ptr>] where <len> is the length of the byteorder hexa string. - * All size and lenghts are written as single characters here. - * - * Note that no byte ordering info is emitted when <network> is true, since - * integers will be emitted in network order in that case. - */ -static int magic_write(pTHX_ stcxt_t *cxt) -{ - /* - * Starting with 0.6, the "use_network_order" byte flag is also used to - * indicate the version number of the binary image, encoded in the upper - * bits. The bit 0 is always used to indicate network order. - */ - /* - * Starting with 0.7, a full byte is dedicated to the minor version of - * the binary format, which is incremented only when new markers are - * introduced, for instance, but when backward compatibility is preserved. - */ - - /* Make these at compile time. The WRITE() macro is sufficiently complex - that it saves about 200 bytes doing it this way and only using it - once. */ - static const unsigned char network_file_header[] = { - MAGICSTR_BYTES, - (STORABLE_BIN_MAJOR << 1) | 1, - STORABLE_BIN_WRITE_MINOR - }; - static const unsigned char file_header[] = { - MAGICSTR_BYTES, - (STORABLE_BIN_MAJOR << 1) | 0, - STORABLE_BIN_WRITE_MINOR, - /* sizeof the array includes the 0 byte at the end: */ - (char) sizeof (byteorderstr) - 1, - BYTEORDER_BYTES, - (unsigned char) sizeof(int), - (unsigned char) sizeof(long), - (unsigned char) sizeof(char *), - (unsigned char) sizeof(NV) - }; -#ifdef USE_56_INTERWORK_KLUDGE - static const unsigned char file_header_56[] = { - MAGICSTR_BYTES, - (STORABLE_BIN_MAJOR << 1) | 0, - STORABLE_BIN_WRITE_MINOR, - /* sizeof the array includes the 0 byte at the end: */ - (char) sizeof (byteorderstr_56) - 1, - BYTEORDER_BYTES_56, - (unsigned char) sizeof(int), - (unsigned char) sizeof(long), - (unsigned char) sizeof(char *), - (unsigned char) sizeof(NV) - }; -#endif - const unsigned char *header; - SSize_t length; - - TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) : -1)); - - if (cxt->netorder) { - header = network_file_header; - length = sizeof (network_file_header); - } else { -#ifdef USE_56_INTERWORK_KLUDGE - if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) { - header = file_header_56; - length = sizeof (file_header_56); - } else -#endif - { - header = file_header; - length = sizeof (file_header); - } - } - - if (!cxt->fio) { - /* sizeof the array includes the 0 byte at the end. */ - header += sizeof (magicstr) - 1; - length -= sizeof (magicstr) - 1; - } - - WRITE( (unsigned char*) header, length); - - if (!cxt->netorder) { - TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)", - (unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1, - (int) sizeof(int), (int) sizeof(long), - (int) sizeof(char *), (int) sizeof(NV))); - } - return 0; -} - -/* - * do_store - * - * Common code for store operations. - * - * When memory store is requested (f = NULL) and a non null SV* is given in - * `res', it is filled with a new SV created out of the memory buffer. - * - * It is required to provide a non-null `res' when the operation type is not - * dclone() and store() is performed to memory. - */ -static int do_store( - pTHX_ - PerlIO *f, - SV *sv, - int optype, - int network_order, - SV **res) -{ - dSTCXT; - int status; - - ASSERT(!(f == 0 && !(optype & ST_CLONE)) || res, - ("must supply result SV pointer for real recursion to memory")); - - TRACEME(("do_store (optype=%d, netorder=%d)", - optype, network_order)); - - optype |= ST_STORE; - - /* - * Workaround for CROAK leak: if they enter with a "dirty" context, - * free up memory for them now. - */ - - if (cxt->s_dirty) - clean_context(aTHX_ cxt); - - /* - * Now that STORABLE_xxx hooks exist, it is possible that they try to - * re-enter store() via the hooks. We need to stack contexts. - */ - - if (cxt->entry) - cxt = allocate_context(aTHX_ cxt); - - cxt->entry++; - - ASSERT(cxt->entry == 1, ("starting new recursion")); - ASSERT(!cxt->s_dirty, ("clean context")); - - /* - * Ensure sv is actually a reference. From perl, we called something - * like: - * pstore(aTHX_ FILE, \@array); - * so we must get the scalar value behing that reference. - */ - - if (!SvROK(sv)) - CROAK(("Not a reference")); - sv = SvRV(sv); /* So follow it to know what to store */ - - /* - * If we're going to store to memory, reset the buffer. - */ - - if (!f) - MBUF_INIT(0); - - /* - * Prepare context and emit headers. - */ - - init_store_context(aTHX_ cxt, f, optype, network_order); - - if (-1 == magic_write(aTHX_ cxt)) /* Emit magic and ILP info */ - return 0; /* Error */ - - /* - * Recursively store object... - */ - - ASSERT(is_storing(aTHX), ("within store operation")); - - status = store(aTHX_ cxt, sv); /* Just do it! */ - - /* - * If they asked for a memory store and they provided an SV pointer, - * make an SV string out of the buffer and fill their pointer. - * - * When asking for ST_REAL, it's MANDATORY for the caller to provide - * an SV, since context cleanup might free the buffer if we did recurse. - * (unless caller is dclone(), which is aware of that). - */ - - if (!cxt->fio && res) - *res = mbuf2sv(aTHX); - - /* - * Final cleanup. - * - * The "root" context is never freed, since it is meant to be always - * handy for the common case where no recursion occurs at all (i.e. - * we enter store() outside of any Storable code and leave it, period). - * We know it's the "root" context because there's nothing stacked - * underneath it. - * - * OPTIMIZATION: - * - * When deep cloning, we don't free the context: doing so would force - * us to copy the data in the memory buffer. Sicne we know we're - * about to enter do_retrieve... - */ - - clean_store_context(aTHX_ cxt); - if (cxt->prev && !(cxt->optype & ST_CLONE)) - free_context(aTHX_ cxt); - - TRACEME(("do_store returns %d", status)); - - return status == 0; -} - -/* - * pstore - * - * Store the transitive data closure of given object to disk. - * Returns 0 on error, a true value otherwise. - */ -static int pstore(pTHX_ PerlIO *f, SV *sv) -{ - TRACEME(("pstore")); - return do_store(aTHX_ f, sv, 0, FALSE, (SV**) 0); - -} - -/* - * net_pstore - * - * Same as pstore(), but network order is used for integers and doubles are - * emitted as strings. - */ -static int net_pstore(pTHX_ PerlIO *f, SV *sv) -{ - TRACEME(("net_pstore")); - return do_store(aTHX_ f, sv, 0, TRUE, (SV**) 0); -} - -/*** - *** Memory stores. - ***/ - -/* - * mbuf2sv - * - * Build a new SV out of the content of the internal memory buffer. - */ -static SV *mbuf2sv(pTHX) -{ - dSTCXT; - - return newSVpv(mbase, MBUF_SIZE()); -} - -/* - * mstore - * - * Store the transitive data closure of given object to memory. - * Returns undef on error, a scalar value containing the data otherwise. - */ -static SV *mstore(pTHX_ SV *sv) -{ - SV *out; - - TRACEME(("mstore")); - - if (!do_store(aTHX_ (PerlIO*) 0, sv, 0, FALSE, &out)) - return &PL_sv_undef; - - return out; -} - -/* - * net_mstore - * - * Same as mstore(), but network order is used for integers and doubles are - * emitted as strings. - */ -static SV *net_mstore(pTHX_ SV *sv) -{ - SV *out; - - TRACEME(("net_mstore")); - - if (!do_store(aTHX_ (PerlIO*) 0, sv, 0, TRUE, &out)) - return &PL_sv_undef; - - return out; -} - -/*** - *** Specific retrieve callbacks. - ***/ - -/* - * retrieve_other - * - * Return an error via croak, since it is not possible that we get here - * under normal conditions, when facing a file produced via pstore(). - */ -static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname) -{ - if ( - cxt->ver_major != STORABLE_BIN_MAJOR && - cxt->ver_minor != STORABLE_BIN_MINOR - ) { - CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d", - cxt->fio ? "file" : "string", - cxt->ver_major, cxt->ver_minor, - STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); - } else { - CROAK(("Corrupted storable %s (binary v%d.%d)", - cxt->fio ? "file" : "string", - cxt->ver_major, cxt->ver_minor)); - } - - return (SV *) 0; /* Just in case */ -} - -/* - * retrieve_idx_blessed - * - * Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read. - * <index> can be coded on either 1 or 5 bytes. - */ -static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname) -{ - I32 idx; - const char *classname; - SV **sva; - SV *sv; - - TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum)); - ASSERT(!cname, ("no bless-into class given here, got %s", cname)); - - GETMARK(idx); /* Index coded on a single char? */ - if (idx & 0x80) - RLEN(idx); - - /* - * Fetch classname in `aclass' - */ - - sva = av_fetch(cxt->aclass, idx, FALSE); - if (!sva) - CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx)); - - classname = SvPVX(*sva); /* We know it's a PV, by construction */ - - TRACEME(("class ID %d => %s", idx, classname)); - - /* - * Retrieve object and bless it. - */ - - sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */ - - return sv; -} - -/* - * retrieve_blessed - * - * Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read. - * <len> can be coded on either 1 or 5 bytes. - */ -static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname) -{ - I32 len; - SV *sv; - char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ - char *classname = buf; - char *malloced_classname = NULL; - - TRACEME(("retrieve_blessed (#%d)", cxt->tagnum)); - ASSERT(!cname, ("no bless-into class given here, got %s", cname)); - - /* - * Decode class name length and read that name. - * - * Short classnames have two advantages: their length is stored on one - * single byte, and the string can be read on the stack. - */ - - GETMARK(len); /* Length coded on a single char? */ - if (len & 0x80) { - RLEN(len); - TRACEME(("** allocating %d bytes for class name", len+1)); - New(10003, classname, len+1, char); - malloced_classname = classname; - } - SAFEPVREAD(classname, len, malloced_classname); - classname[len] = '\0'; /* Mark string end */ - - /* - * It's a new classname, otherwise it would have been an SX_IX_BLESS. - */ - - TRACEME(("new class name \"%s\" will bear ID = %d", classname, cxt->classnum)); - - if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) { - Safefree(malloced_classname); - return (SV *) 0; - } - - /* - * Retrieve object and bless it. - */ - - sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */ - if (malloced_classname) - Safefree(malloced_classname); - - return sv; -} - -/* - * retrieve_hook - * - * Layout: SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>] - * with leading mark already read, as usual. - * - * When recursion was involved during serialization of the object, there - * is an unknown amount of serialized objects after the SX_HOOK mark. Until - * we reach a <flags> marker with the recursion bit cleared. - * - * If the first <flags> byte contains a type of SHT_EXTRA, then the real type - * is held in the <extra> byte, and if the object is tied, the serialized - * magic object comes at the very end: - * - * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object> - * - * This means the STORABLE_thaw hook will NOT get a tied variable during its - * processing (since we won't have seen the magic object by the time the hook - * is called). See comments below for why it was done that way. - */ -static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname) -{ - I32 len; - char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ - char *classname = buf; - unsigned int flags; - I32 len2; - SV *frozen; - I32 len3 = 0; - AV *av = 0; - SV *hook; - SV *sv; - SV *rv; - GV *attach; - int obj_type; - int clone = cxt->optype & ST_CLONE; - char mtype = '\0'; - unsigned int extra_type = 0; - - TRACEME(("retrieve_hook (#%d)", cxt->tagnum)); - ASSERT(!cname, ("no bless-into class given here, got %s", cname)); - - /* - * Read flags, which tell us about the type, and whether we need to recurse. - */ - - GETMARK(flags); - - /* - * Create the (empty) object, and mark it as seen. - * - * This must be done now, because tags are incremented, and during - * serialization, the object tag was affected before recursion could - * take place. - */ - - obj_type = flags & SHF_TYPE_MASK; - switch (obj_type) { - case SHT_SCALAR: - sv = newSV(0); - break; - case SHT_ARRAY: - sv = (SV *) newAV(); - break; - case SHT_HASH: - sv = (SV *) newHV(); - break; - case SHT_EXTRA: - /* - * Read <extra> flag to know the type of the object. - * Record associated magic type for later. - */ - GETMARK(extra_type); - switch (extra_type) { - case SHT_TSCALAR: - sv = newSV(0); - mtype = 'q'; - break; - case SHT_TARRAY: - sv = (SV *) newAV(); - mtype = 'P'; - break; - case SHT_THASH: - sv = (SV *) newHV(); - mtype = 'P'; - break; - default: - return retrieve_other(aTHX_ cxt, 0); /* Let it croak */ - } - break; - default: - return retrieve_other(aTHX_ cxt, 0); /* Let it croak */ - } - SEEN(sv, 0, 0); /* Don't bless yet */ - - /* - * Whilst flags tell us to recurse, do so. - * - * We don't need to remember the addresses returned by retrieval, because - * all the references will be obtained through indirection via the object - * tags in the object-ID list. - * - * We need to decrement the reference count for these objects - * because, if the user doesn't save a reference to them in the hook, - * they must be freed when this context is cleaned. - */ - - while (flags & SHF_NEED_RECURSE) { - TRACEME(("retrieve_hook recursing...")); - rv = retrieve(aTHX_ cxt, 0); - if (!rv) - return (SV *) 0; - SvREFCNT_dec(rv); - TRACEME(("retrieve_hook back with rv=0x%"UVxf, - PTR2UV(rv))); - GETMARK(flags); - } - - if (flags & SHF_IDX_CLASSNAME) { - SV **sva; - I32 idx; - - /* - * Fetch index from `aclass' - */ - - if (flags & SHF_LARGE_CLASSLEN) - RLEN(idx); - else - GETMARK(idx); - - sva = av_fetch(cxt->aclass, idx, FALSE); - if (!sva) - CROAK(("Class name #%"IVdf" should have been seen already", - (IV) idx)); - - classname = SvPVX(*sva); /* We know it's a PV, by construction */ - TRACEME(("class ID %d => %s", idx, classname)); - - } else { - /* - * Decode class name length and read that name. - * - * NOTA BENE: even if the length is stored on one byte, we don't read - * on the stack. Just like retrieve_blessed(), we limit the name to - * LG_BLESS bytes. This is an arbitrary decision. - */ - char *malloced_classname = NULL; - - if (flags & SHF_LARGE_CLASSLEN) - RLEN(len); - else - GETMARK(len); - - if (len > LG_BLESS) { - TRACEME(("** allocating %d bytes for class name", len+1)); - New(10003, classname, len+1, char); - malloced_classname = classname; - } - - SAFEPVREAD(classname, len, malloced_classname); - classname[len] = '\0'; /* Mark string end */ - - /* - * Record new classname. - */ - - if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) { - Safefree(malloced_classname); - return (SV *) 0; - } - } - - TRACEME(("class name: %s", classname)); - - /* - * Decode user-frozen string length and read it in an SV. - * - * For efficiency reasons, we read data directly into the SV buffer. - * To understand that code, read retrieve_scalar() - */ - - if (flags & SHF_LARGE_STRLEN) - RLEN(len2); - else - GETMARK(len2); - - frozen = NEWSV(10002, len2); - if (len2) { - SAFEREAD(SvPVX(frozen), len2, frozen); - SvCUR_set(frozen, len2); - *SvEND(frozen) = '\0'; - } - (void) SvPOK_only(frozen); /* Validates string pointer */ - if (cxt->s_tainted) /* Is input source tainted? */ - SvTAINT(frozen); - - TRACEME(("frozen string: %d bytes", len2)); - - /* - * Decode object-ID list length, if present. - */ - - if (flags & SHF_HAS_LIST) { - if (flags & SHF_LARGE_LISTLEN) - RLEN(len3); - else - GETMARK(len3); - if (len3) { - av = newAV(); - av_extend(av, len3 + 1); /* Leave room for [0] */ - AvFILLp(av) = len3; /* About to be filled anyway */ - } - } - - TRACEME(("has %d object IDs to link", len3)); - - /* - * Read object-ID list into array. - * Because we pre-extended it, we can cheat and fill it manually. - * - * We read object tags and we can convert them into SV* on the fly - * because we know all the references listed in there (as tags) - * have been already serialized, hence we have a valid correspondance - * between each of those tags and the recreated SV. - */ - - if (av) { - SV **ary = AvARRAY(av); - int i; - for (i = 1; i <= len3; i++) { /* We leave [0] alone */ - I32 tag; - SV **svh; - SV *xsv; - - READ_I32(tag); - tag = ntohl(tag); - svh = av_fetch(cxt->aseen, tag, FALSE); - if (!svh) { - if (tag == cxt->where_is_undef) { - /* av_fetch uses PL_sv_undef internally, hence this - somewhat gruesome hack. */ - xsv = &PL_sv_undef; - svh = &xsv; - } else { - CROAK(("Object #%"IVdf" should have been retrieved already", - (IV) tag)); - } - } - xsv = *svh; - ary[i] = SvREFCNT_inc(xsv); - } - } - - /* - * Bless the object and look up the STORABLE_thaw hook. - */ - - BLESS(sv, classname); - - /* Handle attach case; again can't use pkg_can because it only - * caches one method */ - attach = gv_fetchmethod_autoload(SvSTASH(sv), "STORABLE_attach", FALSE); - if (attach && isGV(attach)) { - SV* attached; - SV* attach_hook = newRV((SV*) GvCV(attach)); - - if (av) - CROAK(("STORABLE_attach called with unexpected references")); - av = newAV(); - av_extend(av, 1); - AvFILLp(av) = 0; - AvARRAY(av)[0] = SvREFCNT_inc(frozen); - rv = newSVpv(classname, 0); - attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR); - if (attached && - SvROK(attached) && - sv_derived_from(attached, classname)) - return SvRV(attached); - CROAK(("STORABLE_attach did not return a %s object", classname)); - } - - hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); - if (!hook) { - /* - * Hook not found. Maybe they did not require the module where this - * hook is defined yet? - * - * If the load below succeeds, we'll be able to find the hook. - * Still, it only works reliably when each class is defined in a - * file of its own. - */ - - TRACEME(("No STORABLE_thaw defined for objects of class %s", classname)); - TRACEME(("Going to load module '%s'", classname)); - load_module(PERL_LOADMOD_NOIMPORT, newSVpv(classname, 0), Nullsv); - - /* - * We cache results of pkg_can, so we need to uncache before attempting - * the lookup again. - */ - - pkg_uncache(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); - hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); - - if (!hook) - CROAK(("No STORABLE_thaw defined for objects of class %s " - "(even after a \"require %s;\")", classname, classname)); - } - - /* - * If we don't have an `av' yet, prepare one. - * Then insert the frozen string as item [0]. - */ - - if (!av) { - av = newAV(); - av_extend(av, 1); - AvFILLp(av) = 0; - } - AvARRAY(av)[0] = SvREFCNT_inc(frozen); - - /* - * Call the hook as: - * - * $object->STORABLE_thaw($cloning, $frozen, @refs); - * - * where $object is our blessed (empty) object, $cloning is a boolean - * telling whether we're running a deep clone, $frozen is the frozen - * string the user gave us in his serializing hook, and @refs, which may - * be empty, is the list of extra references he returned along for us - * to serialize. - * - * In effect, the hook is an alternate creation routine for the class, - * the object itself being already created by the runtime. - */ - - TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)", - classname, PTR2UV(sv), (IV) AvFILLp(av) + 1)); - - rv = newRV(sv); - (void) scalar_call(aTHX_ rv, hook, clone, av, G_SCALAR|G_DISCARD); - SvREFCNT_dec(rv); - - /* - * Final cleanup. - */ - - SvREFCNT_dec(frozen); - av_undef(av); - sv_free((SV *) av); - if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) - Safefree(classname); - - /* - * If we had an <extra> type, then the object was not as simple, and - * we need to restore extra magic now. - */ - - if (!extra_type) - return sv; - - TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv))); - - rv = retrieve(aTHX_ cxt, 0); /* Retrieve <magic object> */ - - TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf, - PTR2UV(rv), PTR2UV(sv))); - - switch (extra_type) { - case SHT_TSCALAR: - sv_upgrade(sv, SVt_PVMG); - break; - case SHT_TARRAY: - sv_upgrade(sv, SVt_PVAV); - AvREAL_off((AV *)sv); - break; - case SHT_THASH: - sv_upgrade(sv, SVt_PVHV); - break; - default: - CROAK(("Forgot to deal with extra type %d", extra_type)); - break; - } - - /* - * Adding the magic only now, well after the STORABLE_thaw hook was called - * means the hook cannot know it deals with an object whose variable is - * tied. But this is happening when retrieving $o in the following case: - * - * my %h; - * tie %h, 'FOO'; - * my $o = bless \%h, 'BAR'; - * - * The 'BAR' class is NOT the one where %h is tied into. Therefore, as - * far as the 'BAR' class is concerned, the fact that %h is not a REAL - * hash but a tied one should not matter at all, and remain transparent. - * This means the magic must be restored by Storable AFTER the hook is - * called. - * - * That looks very reasonable to me, but then I've come up with this - * after a bug report from David Nesting, who was trying to store such - * an object and caused Storable to fail. And unfortunately, it was - * also the easiest way to retrofit support for blessed ref to tied objects - * into the existing design. -- RAM, 17/02/2001 - */ - - sv_magic(sv, rv, mtype, (char *)NULL, 0); - SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */ - - return sv; -} - -/* - * retrieve_ref - * - * Retrieve reference to some other scalar. - * Layout is SX_REF <object>, with SX_REF already read. - */ -static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *rv; - SV *sv; - - TRACEME(("retrieve_ref (#%d)", cxt->tagnum)); - - /* - * We need to create the SV that holds the reference to the yet-to-retrieve - * object now, so that we may record the address in the seen table. - * Otherwise, if the object to retrieve references us, we won't be able - * to resolve the SX_OBJECT we'll see at that point! Hence we cannot - * do the retrieve first and use rv = newRV(sv) since it will be too late - * for SEEN() recording. - */ - - rv = NEWSV(10002, 0); - SEEN(rv, cname, 0); /* Will return if rv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ - - /* - * WARNING: breaks RV encapsulation. - * - * Now for the tricky part. We have to upgrade our existing SV, so that - * it is now an RV on sv... Again, we cheat by duplicating the code - * held in newSVrv(), since we already got our SV from retrieve(). - * - * We don't say: - * - * SvRV(rv) = SvREFCNT_inc(sv); - * - * here because the reference count we got from retrieve() above is - * already correct: if the object was retrieved from the file, then - * its reference count is one. Otherwise, if it was retrieved via - * an SX_OBJECT indication, a ref count increment was done. - */ - - if (cname) { - /* No need to do anything, as rv will already be PVMG. */ - assert (SvTYPE(rv) == SVt_RV || SvTYPE(rv) >= SVt_PV); - } else { - sv_upgrade(rv, SVt_RV); - } - - SvRV_set(rv, sv); /* $rv = \$sv */ - SvROK_on(rv); - - TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv))); - - return rv; -} - -/* - * retrieve_weakref - * - * Retrieve weak reference to some other scalar. - * Layout is SX_WEAKREF <object>, with SX_WEAKREF already read. - */ -static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv; - - TRACEME(("retrieve_weakref (#%d)", cxt->tagnum)); - - sv = retrieve_ref(aTHX_ cxt, cname); - if (sv) { -#ifdef SvWEAKREF - sv_rvweaken(sv); -#else - WEAKREF_CROAK(); -#endif - } - return sv; -} - -/* - * retrieve_overloaded - * - * Retrieve reference to some other scalar with overloading. - * Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read. - */ -static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *rv; - SV *sv; - HV *stash; - - TRACEME(("retrieve_overloaded (#%d)", cxt->tagnum)); - - /* - * Same code as retrieve_ref(), duplicated to avoid extra call. - */ - - rv = NEWSV(10002, 0); - SEEN(rv, cname, 0); /* Will return if rv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ - - /* - * WARNING: breaks RV encapsulation. - */ - - SvUPGRADE(rv, SVt_RV); - SvRV_set(rv, sv); /* $rv = \$sv */ - SvROK_on(rv); - - /* - * Restore overloading magic. - */ - - stash = SvTYPE(sv) ? (HV *) SvSTASH (sv) : 0; - if (!stash) { - CROAK(("Cannot restore overloading on %s(0x%"UVxf - ") (package <unknown>)", - sv_reftype(sv, FALSE), - PTR2UV(sv))); - } - if (!Gv_AMG(stash)) { - const char *package = HvNAME_get(stash); - TRACEME(("No overloading defined for package %s", package)); - TRACEME(("Going to load module '%s'", package)); - load_module(PERL_LOADMOD_NOIMPORT, newSVpv(package, 0), Nullsv); - if (!Gv_AMG(stash)) { - CROAK(("Cannot restore overloading on %s(0x%"UVxf - ") (package %s) (even after a \"require %s;\")", - sv_reftype(sv, FALSE), - PTR2UV(sv), - package, package)); - } - } - - SvAMAGIC_on(rv); - - TRACEME(("ok (retrieve_overloaded at 0x%"UVxf")", PTR2UV(rv))); - - return rv; -} - -/* - * retrieve_weakoverloaded - * - * Retrieve weak overloaded reference to some other scalar. - * Layout is SX_WEAKOVERLOADED <object>, with SX_WEAKOVERLOADED already read. - */ -static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv; - - TRACEME(("retrieve_weakoverloaded (#%d)", cxt->tagnum)); - - sv = retrieve_overloaded(aTHX_ cxt, cname); - if (sv) { -#ifdef SvWEAKREF - sv_rvweaken(sv); -#else - WEAKREF_CROAK(); -#endif - } - return sv; -} - -/* - * retrieve_tied_array - * - * Retrieve tied array - * Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read. - */ -static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *tv; - SV *sv; - - TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum)); - - tv = NEWSV(10002, 0); - SEEN(tv, cname, 0); /* Will return if tv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ - - sv_upgrade(tv, SVt_PVAV); - AvREAL_off((AV *)tv); - sv_magic(tv, sv, 'P', (char *)NULL, 0); - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ - - TRACEME(("ok (retrieve_tied_array at 0x%"UVxf")", PTR2UV(tv))); - - return tv; -} - -/* - * retrieve_tied_hash - * - * Retrieve tied hash - * Layout is SX_TIED_HASH <object>, with SX_TIED_HASH already read. - */ -static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *tv; - SV *sv; - - TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum)); - - tv = NEWSV(10002, 0); - SEEN(tv, cname, 0); /* Will return if tv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ - - sv_upgrade(tv, SVt_PVHV); - sv_magic(tv, sv, 'P', (char *)NULL, 0); - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ - - TRACEME(("ok (retrieve_tied_hash at 0x%"UVxf")", PTR2UV(tv))); - - return tv; -} - -/* - * retrieve_tied_scalar - * - * Retrieve tied scalar - * Layout is SX_TIED_SCALAR <object>, with SX_TIED_SCALAR already read. - */ -static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *tv; - SV *sv, *obj = NULL; - - TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum)); - - tv = NEWSV(10002, 0); - SEEN(tv, cname, 0); /* Will return if rv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) { - return (SV *) 0; /* Failed */ - } - else if (SvTYPE(sv) != SVt_NULL) { - obj = sv; - } - - sv_upgrade(tv, SVt_PVMG); - sv_magic(tv, obj, 'q', (char *)NULL, 0); - - if (obj) { - /* Undo refcnt inc from sv_magic() */ - SvREFCNT_dec(obj); - } - - TRACEME(("ok (retrieve_tied_scalar at 0x%"UVxf")", PTR2UV(tv))); - - return tv; -} - -/* - * retrieve_tied_key - * - * Retrieve reference to value in a tied hash. - * Layout is SX_TIED_KEY <object> <key>, with SX_TIED_KEY already read. - */ -static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *tv; - SV *sv; - SV *key; - - TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum)); - - tv = NEWSV(10002, 0); - SEEN(tv, cname, 0); /* Will return if tv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ - - key = retrieve(aTHX_ cxt, 0); /* Retrieve <key> */ - if (!key) - return (SV *) 0; /* Failed */ - - sv_upgrade(tv, SVt_PVMG); - sv_magic(tv, sv, 'p', (char *)key, HEf_SVKEY); - SvREFCNT_dec(key); /* Undo refcnt inc from sv_magic() */ - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ - - return tv; -} - -/* - * retrieve_tied_idx - * - * Retrieve reference to value in a tied array. - * Layout is SX_TIED_IDX <object> <idx>, with SX_TIED_IDX already read. - */ -static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *tv; - SV *sv; - I32 idx; - - TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum)); - - tv = NEWSV(10002, 0); - SEEN(tv, cname, 0); /* Will return if tv is null */ - sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */ - if (!sv) - return (SV *) 0; /* Failed */ - - RLEN(idx); /* Retrieve <idx> */ - - sv_upgrade(tv, SVt_PVMG); - sv_magic(tv, sv, 'p', (char *)NULL, idx); - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ - - return tv; -} - - -/* - * retrieve_lscalar - * - * Retrieve defined long (string) scalar. - * - * Layout is SX_LSCALAR <length> <data>, with SX_LSCALAR already read. - * The scalar is "long" in that <length> is larger than LG_SCALAR so it - * was not stored on a single byte. - */ -static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname) -{ - I32 len; - SV *sv; - - RLEN(len); - TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, (IV) len)); - - /* - * Allocate an empty scalar of the suitable length. - */ - - sv = NEWSV(10002, len); - SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ - - if (len == 0) { - sv_setpvn(sv, "", 0); - return sv; - } - - /* - * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. - * - * Now, for efficiency reasons, read data directly inside the SV buffer, - * and perform the SV final settings directly by duplicating the final - * work done by sv_setpv. Since we're going to allocate lots of scalars - * this way, it's worth the hassle and risk. - */ - - SAFEREAD(SvPVX(sv), len, sv); - SvCUR_set(sv, len); /* Record C string length */ - *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ - (void) SvPOK_only(sv); /* Validate string pointer */ - if (cxt->s_tainted) /* Is input source tainted? */ - SvTAINT(sv); /* External data cannot be trusted */ - - TRACEME(("large scalar len %"IVdf" '%s'", (IV) len, SvPVX(sv))); - TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv))); - - return sv; -} - -/* - * retrieve_scalar - * - * Retrieve defined short (string) scalar. - * - * Layout is SX_SCALAR <length> <data>, with SX_SCALAR already read. - * The scalar is "short" so <length> is single byte. If it is 0, there - * is no <data> section. - */ -static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname) -{ - int len; - SV *sv; - - GETMARK(len); - TRACEME(("retrieve_scalar (#%d), len = %d", cxt->tagnum, len)); - - /* - * Allocate an empty scalar of the suitable length. - */ - - sv = NEWSV(10002, len); - SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ - - /* - * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. - */ - - if (len == 0) { - /* - * newSV did not upgrade to SVt_PV so the scalar is undefined. - * To make it defined with an empty length, upgrade it now... - * Don't upgrade to a PV if the original type contains more - * information than a scalar. - */ - if (SvTYPE(sv) <= SVt_PV) { - sv_upgrade(sv, SVt_PV); - } - SvGROW(sv, 1); - *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ - TRACEME(("ok (retrieve_scalar empty at 0x%"UVxf")", PTR2UV(sv))); - } else { - /* - * Now, for efficiency reasons, read data directly inside the SV buffer, - * and perform the SV final settings directly by duplicating the final - * work done by sv_setpv. Since we're going to allocate lots of scalars - * this way, it's worth the hassle and risk. - */ - SAFEREAD(SvPVX(sv), len, sv); - SvCUR_set(sv, len); /* Record C string length */ - *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ - TRACEME(("small scalar len %d '%s'", len, SvPVX(sv))); - } - - (void) SvPOK_only(sv); /* Validate string pointer */ - if (cxt->s_tainted) /* Is input source tainted? */ - SvTAINT(sv); /* External data cannot be trusted */ - - TRACEME(("ok (retrieve_scalar at 0x%"UVxf")", PTR2UV(sv))); - return sv; -} - -/* - * retrieve_utf8str - * - * Like retrieve_scalar(), but tag result as utf8. - * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. - */ -static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv; - - TRACEME(("retrieve_utf8str")); - - sv = retrieve_scalar(aTHX_ cxt, cname); - if (sv) { -#ifdef HAS_UTF8_SCALARS - SvUTF8_on(sv); -#else - if (cxt->use_bytes < 0) - cxt->use_bytes - = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD)) - ? 1 : 0); - if (cxt->use_bytes == 0) - UTF8_CROAK(); -#endif - } - - return sv; -} - -/* - * retrieve_lutf8str - * - * Like retrieve_lscalar(), but tag result as utf8. - * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. - */ -static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv; - - TRACEME(("retrieve_lutf8str")); - - sv = retrieve_lscalar(aTHX_ cxt, cname); - if (sv) { -#ifdef HAS_UTF8_SCALARS - SvUTF8_on(sv); -#else - if (cxt->use_bytes < 0) - cxt->use_bytes - = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD)) - ? 1 : 0); - if (cxt->use_bytes == 0) - UTF8_CROAK(); -#endif - } - return sv; -} - -/* - * retrieve_integer - * - * Retrieve defined integer. - * Layout is SX_INTEGER <data>, whith SX_INTEGER already read. - */ -static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv; - IV iv; - - TRACEME(("retrieve_integer (#%d)", cxt->tagnum)); - - READ(&iv, sizeof(iv)); - sv = newSViv(iv); - SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ - - TRACEME(("integer %"IVdf, iv)); - TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv))); - - return sv; -} - -/* - * retrieve_netint - * - * Retrieve defined integer in network order. - * Layout is SX_NETINT <data>, whith SX_NETINT already read. - */ -static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv; - I32 iv; - - TRACEME(("retrieve_netint (#%d)", cxt->tagnum)); - - READ_I32(iv); -#ifdef HAS_NTOHL - sv = newSViv((int) ntohl(iv)); - TRACEME(("network integer %d", (int) ntohl(iv))); -#else - sv = newSViv(iv); - TRACEME(("network integer (as-is) %d", iv)); -#endif - SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ - - TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv))); - - return sv; -} - -/* - * retrieve_double - * - * Retrieve defined double. - * Layout is SX_DOUBLE <data>, whith SX_DOUBLE already read. - */ -static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv; - NV nv; - - TRACEME(("retrieve_double (#%d)", cxt->tagnum)); - - READ(&nv, sizeof(nv)); - sv = newSVnv(nv); - SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ - - TRACEME(("double %"NVff, nv)); - TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv))); - - return sv; -} - -/* - * retrieve_byte - * - * Retrieve defined byte (small integer within the [-128, +127] range). - * Layout is SX_BYTE <data>, whith SX_BYTE already read. - */ -static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv; - int siv; - signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */ - - TRACEME(("retrieve_byte (#%d)", cxt->tagnum)); - - GETMARK(siv); - TRACEME(("small integer read as %d", (unsigned char) siv)); - tmp = (unsigned char) siv - 128; - sv = newSViv(tmp); - SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ - - TRACEME(("byte %d", tmp)); - TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv))); - - return sv; -} - -/* - * retrieve_undef - * - * Return the undefined value. - */ -static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV* sv; - - TRACEME(("retrieve_undef")); - - sv = newSV(0); - SEEN(sv, cname, 0); - - return sv; -} - -/* - * retrieve_sv_undef - * - * Return the immortal undefined value. - */ -static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv = &PL_sv_undef; - - TRACEME(("retrieve_sv_undef")); - - /* Special case PL_sv_undef, as av_fetch uses it internally to mark - deleted elements, and will return NULL (fetch failed) whenever it - is fetched. */ - if (cxt->where_is_undef == -1) { - cxt->where_is_undef = cxt->tagnum; - } - SEEN(sv, cname, 1); - return sv; -} - -/* - * retrieve_sv_yes - * - * Return the immortal yes value. - */ -static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv = &PL_sv_yes; - - TRACEME(("retrieve_sv_yes")); - - SEEN(sv, cname, 1); - return sv; -} - -/* - * retrieve_sv_no - * - * Return the immortal no value. - */ -static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname) -{ - SV *sv = &PL_sv_no; - - TRACEME(("retrieve_sv_no")); - - SEEN(sv, cname, 1); - return sv; -} - -/* - * retrieve_array - * - * Retrieve a whole array. - * Layout is SX_ARRAY <size> followed by each item, in increading index order. - * Each item is stored as <object>. - * - * When we come here, SX_ARRAY has been read already. - */ -static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) -{ - I32 len; - I32 i; - AV *av; - SV *sv; - - TRACEME(("retrieve_array (#%d)", cxt->tagnum)); - - /* - * Read length, and allocate array, then pre-extend it. - */ - - RLEN(len); - TRACEME(("size = %d", len)); - av = newAV(); - SEEN(av, cname, 0); /* Will return if array not allocated nicely */ - if (len) - av_extend(av, len); - else - return (SV *) av; /* No data follow if array is empty */ - - /* - * Now get each item in turn... - */ - - for (i = 0; i < len; i++) { - TRACEME(("(#%d) item", i)); - sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ - if (!sv) - return (SV *) 0; - if (av_store(av, i, sv) == 0) - return (SV *) 0; - } - - TRACEME(("ok (retrieve_array at 0x%"UVxf")", PTR2UV(av))); - - return (SV *) av; -} - -/* - * retrieve_hash - * - * Retrieve a whole hash table. - * Layout is SX_HASH <size> followed by each key/value pair, in random order. - * Keys are stored as <length> <data>, the <data> section being omitted - * if length is 0. - * Values are stored as <object>. - * - * When we come here, SX_HASH has been read already. - */ -static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname) -{ - I32 len; - I32 size; - I32 i; - HV *hv; - SV *sv; - - TRACEME(("retrieve_hash (#%d)", cxt->tagnum)); - - /* - * Read length, allocate table. - */ - - RLEN(len); - TRACEME(("size = %d", len)); - hv = newHV(); - SEEN(hv, cname, 0); /* Will return if table not allocated properly */ - if (len == 0) - return (SV *) hv; /* No data follow if table empty */ - hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */ - - /* - * Now get each key/value pair in turn... - */ - - for (i = 0; i < len; i++) { - /* - * Get value first. - */ - - TRACEME(("(#%d) value", i)); - sv = retrieve(aTHX_ cxt, 0); - if (!sv) - return (SV *) 0; - - /* - * Get key. - * Since we're reading into kbuf, we must ensure we're not - * recursing between the read and the hv_store() where it's used. - * Hence the key comes after the value. - */ - - RLEN(size); /* Get key size */ - KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ - if (size) - READ(kbuf, size); - kbuf[size] = '\0'; /* Mark string end, just in case */ - TRACEME(("(#%d) key '%s'", i, kbuf)); - - /* - * Enter key/value pair into hash table. - */ - - if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) - return (SV *) 0; - } - - TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); - - return (SV *) hv; -} - -/* - * retrieve_hash - * - * Retrieve a whole hash table. - * Layout is SX_HASH <size> followed by each key/value pair, in random order. - * Keys are stored as <length> <data>, the <data> section being omitted - * if length is 0. - * Values are stored as <object>. - * - * When we come here, SX_HASH has been read already. - */ -static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) -{ - dVAR; - I32 len; - I32 size; - I32 i; - HV *hv; - SV *sv; - int hash_flags; - - GETMARK(hash_flags); - TRACEME(("retrieve_flag_hash (#%d)", cxt->tagnum)); - /* - * Read length, allocate table. - */ - -#ifndef HAS_RESTRICTED_HASHES - if (hash_flags & SHV_RESTRICTED) { - if (cxt->derestrict < 0) - cxt->derestrict - = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", GV_ADD)) - ? 1 : 0); - if (cxt->derestrict == 0) - RESTRICTED_HASH_CROAK(); - } -#endif - - RLEN(len); - TRACEME(("size = %d, flags = %d", len, hash_flags)); - hv = newHV(); - SEEN(hv, cname, 0); /* Will return if table not allocated properly */ - if (len == 0) - return (SV *) hv; /* No data follow if table empty */ - hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */ - - /* - * Now get each key/value pair in turn... - */ - - for (i = 0; i < len; i++) { - int flags; - int store_flags = 0; - /* - * Get value first. - */ - - TRACEME(("(#%d) value", i)); - sv = retrieve(aTHX_ cxt, 0); - if (!sv) - return (SV *) 0; - - GETMARK(flags); -#ifdef HAS_RESTRICTED_HASHES - if ((hash_flags & SHV_RESTRICTED) && (flags & SHV_K_LOCKED)) - SvREADONLY_on(sv); -#endif - - if (flags & SHV_K_ISSV) { - /* XXX you can't set a placeholder with an SV key. - Then again, you can't get an SV key. - Without messing around beyond what the API is supposed to do. - */ - SV *keysv; - TRACEME(("(#%d) keysv, flags=%d", i, flags)); - keysv = retrieve(aTHX_ cxt, 0); - if (!keysv) - return (SV *) 0; - - if (!hv_store_ent(hv, keysv, sv, 0)) - return (SV *) 0; - } else { - /* - * Get key. - * Since we're reading into kbuf, we must ensure we're not - * recursing between the read and the hv_store() where it's used. - * Hence the key comes after the value. - */ - - if (flags & SHV_K_PLACEHOLDER) { - SvREFCNT_dec (sv); - sv = &PL_sv_placeholder; - store_flags |= HVhek_PLACEHOLD; - } - if (flags & SHV_K_UTF8) { -#ifdef HAS_UTF8_HASHES - store_flags |= HVhek_UTF8; -#else - if (cxt->use_bytes < 0) - cxt->use_bytes - = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD)) - ? 1 : 0); - if (cxt->use_bytes == 0) - UTF8_CROAK(); -#endif - } -#ifdef HAS_UTF8_HASHES - if (flags & SHV_K_WASUTF8) - store_flags |= HVhek_WASUTF8; -#endif - - RLEN(size); /* Get key size */ - KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ - if (size) - READ(kbuf, size); - kbuf[size] = '\0'; /* Mark string end, just in case */ - TRACEME(("(#%d) key '%s' flags %X store_flags %X", i, kbuf, - flags, store_flags)); - - /* - * Enter key/value pair into hash table. - */ - -#ifdef HAS_RESTRICTED_HASHES - if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0) - return (SV *) 0; -#else - if (!(store_flags & HVhek_PLACEHOLD)) - if (hv_store(hv, kbuf, size, sv, 0) == 0) - return (SV *) 0; -#endif - } - } -#ifdef HAS_RESTRICTED_HASHES - if (hash_flags & SHV_RESTRICTED) - SvREADONLY_on(hv); -#endif - - TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); - - return (SV *) hv; -} - -/* - * retrieve_code - * - * Return a code reference. - */ -static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname) -{ -#if PERL_VERSION < 6 - CROAK(("retrieve_code does not work with perl 5.005 or less\n")); -#else - dSP; - int type, count, tagnum; - SV *cv; - SV *sv, *text, *sub; - - TRACEME(("retrieve_code (#%d)", cxt->tagnum)); - - /* - * Insert dummy SV in the aseen array so that we don't screw - * up the tag numbers. We would just make the internal - * scalar an untagged item in the stream, but - * retrieve_scalar() calls SEEN(). So we just increase the - * tag number. - */ - tagnum = cxt->tagnum; - sv = newSViv(0); - SEEN(sv, cname, 0); - - /* - * Retrieve the source of the code reference - * as a small or large scalar - */ - - GETMARK(type); - switch (type) { - case SX_SCALAR: - text = retrieve_scalar(aTHX_ cxt, cname); - break; - case SX_LSCALAR: - text = retrieve_lscalar(aTHX_ cxt, cname); - break; - default: - CROAK(("Unexpected type %d in retrieve_code\n", type)); - } - - /* - * prepend "sub " to the source - */ - - sub = newSVpvn("sub ", 4); - sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */ - SvREFCNT_dec(text); - - /* - * evaluate the source to a code reference and use the CV value - */ - - if (cxt->eval == NULL) { - cxt->eval = perl_get_sv("Storable::Eval", GV_ADD); - SvREFCNT_inc(cxt->eval); - } - if (!SvTRUE(cxt->eval)) { - if ( - cxt->forgive_me == 0 || - (cxt->forgive_me < 0 && !(cxt->forgive_me = - SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0)) - ) { - CROAK(("Can't eval, please set $Storable::Eval to a true value")); - } else { - sv = newSVsv(sub); - /* fix up the dummy entry... */ - av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); - return sv; - } - } - - ENTER; - SAVETMPS; - - if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) { - SV* errsv = get_sv("@", GV_ADD); - sv_setpvn(errsv, "", 0); /* clear $@ */ - PUSHMARK(sp); - XPUSHs(sv_2mortal(newSVsv(sub))); - PUTBACK; - count = call_sv(cxt->eval, G_SCALAR); - SPAGAIN; - if (count != 1) - CROAK(("Unexpected return value from $Storable::Eval callback\n")); - cv = POPs; - if (SvTRUE(errsv)) { - CROAK(("code %s caused an error: %s", - SvPV_nolen(sub), SvPV_nolen(errsv))); - } - PUTBACK; - } else { - cv = eval_pv(SvPV_nolen(sub), TRUE); - } - if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) { - sv = SvRV(cv); - } else { - CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub))); - } - - SvREFCNT_inc(sv); /* XXX seems to be necessary */ - SvREFCNT_dec(sub); - - FREETMPS; - LEAVE; - /* fix up the dummy entry... */ - av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); - - return sv; -#endif -} - -/* - * old_retrieve_array - * - * Retrieve a whole array in pre-0.6 binary format. - * - * Layout is SX_ARRAY <size> followed by each item, in increading index order. - * Each item is stored as SX_ITEM <object> or SX_IT_UNDEF for "holes". - * - * When we come here, SX_ARRAY has been read already. - */ -static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) -{ - I32 len; - I32 i; - AV *av; - SV *sv; - int c; - - TRACEME(("old_retrieve_array (#%d)", cxt->tagnum)); - - /* - * Read length, and allocate array, then pre-extend it. - */ - - RLEN(len); - TRACEME(("size = %d", len)); - av = newAV(); - SEEN(av, 0, 0); /* Will return if array not allocated nicely */ - if (len) - av_extend(av, len); - else - return (SV *) av; /* No data follow if array is empty */ - - /* - * Now get each item in turn... - */ - - for (i = 0; i < len; i++) { - GETMARK(c); - if (c == SX_IT_UNDEF) { - TRACEME(("(#%d) undef item", i)); - continue; /* av_extend() already filled us with undef */ - } - if (c != SX_ITEM) - (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ - TRACEME(("(#%d) item", i)); - sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ - if (!sv) - return (SV *) 0; - if (av_store(av, i, sv) == 0) - return (SV *) 0; - } - - TRACEME(("ok (old_retrieve_array at 0x%"UVxf")", PTR2UV(av))); - - return (SV *) av; -} - -/* - * old_retrieve_hash - * - * Retrieve a whole hash table in pre-0.6 binary format. - * - * Layout is SX_HASH <size> followed by each key/value pair, in random order. - * Keys are stored as SX_KEY <length> <data>, the <data> section being omitted - * if length is 0. - * Values are stored as SX_VALUE <object> or SX_VL_UNDEF for "holes". - * - * When we come here, SX_HASH has been read already. - */ -static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname) -{ - I32 len; - I32 size; - I32 i; - HV *hv; - SV *sv = (SV *) 0; - int c; - SV *sv_h_undef = (SV *) 0; /* hv_store() bug */ - - TRACEME(("old_retrieve_hash (#%d)", cxt->tagnum)); - - /* - * Read length, allocate table. - */ - - RLEN(len); - TRACEME(("size = %d", len)); - hv = newHV(); - SEEN(hv, 0, 0); /* Will return if table not allocated properly */ - if (len == 0) - return (SV *) hv; /* No data follow if table empty */ - hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */ - - /* - * Now get each key/value pair in turn... - */ - - for (i = 0; i < len; i++) { - /* - * Get value first. - */ - - GETMARK(c); - if (c == SX_VL_UNDEF) { - TRACEME(("(#%d) undef value", i)); - /* - * Due to a bug in hv_store(), it's not possible to pass - * &PL_sv_undef to hv_store() as a value, otherwise the - * associated key will not be creatable any more. -- RAM, 14/01/97 - */ - if (!sv_h_undef) - sv_h_undef = newSVsv(&PL_sv_undef); - sv = SvREFCNT_inc(sv_h_undef); - } else if (c == SX_VALUE) { - TRACEME(("(#%d) value", i)); - sv = retrieve(aTHX_ cxt, 0); - if (!sv) - return (SV *) 0; - } else - (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ - - /* - * Get key. - * Since we're reading into kbuf, we must ensure we're not - * recursing between the read and the hv_store() where it's used. - * Hence the key comes after the value. - */ - - GETMARK(c); - if (c != SX_KEY) - (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ - RLEN(size); /* Get key size */ - KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ - if (size) - READ(kbuf, size); - kbuf[size] = '\0'; /* Mark string end, just in case */ - TRACEME(("(#%d) key '%s'", i, kbuf)); - - /* - * Enter key/value pair into hash table. - */ - - if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) - return (SV *) 0; - } - - TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); - - return (SV *) hv; -} - -/*** - *** Retrieval engine. - ***/ - -/* - * magic_check - * - * Make sure the stored data we're trying to retrieve has been produced - * on an ILP compatible system with the same byteorder. It croaks out in - * case an error is detected. [ILP = integer-long-pointer sizes] - * Returns null if error is detected, &PL_sv_undef otherwise. - * - * Note that there's no byte ordering info emitted when network order was - * used at store time. - */ -static SV *magic_check(pTHX_ stcxt_t *cxt) -{ - /* The worst case for a malicious header would be old magic (which is - longer), major, minor, byteorder length byte of 255, 255 bytes of - garbage, sizeof int, long, pointer, NV. - So the worse of that we can read is 255 bytes of garbage plus 4. - Err, I am assuming 8 bit bytes here. Please file a bug report if you're - compiling perl on a system with chars that are larger than 8 bits. - (Even Crays aren't *that* perverse). - */ - unsigned char buf[4 + 255]; - unsigned char *current; - int c; - int length; - int use_network_order; - int use_NV_size; - int old_magic = 0; - int version_major; - int version_minor = 0; - - TRACEME(("magic_check")); - - /* - * The "magic number" is only for files, not when freezing in memory. - */ - - if (cxt->fio) { - /* This includes the '\0' at the end. I want to read the extra byte, - which is usually going to be the major version number. */ - STRLEN len = sizeof(magicstr); - STRLEN old_len; - - READ(buf, (SSize_t)(len)); /* Not null-terminated */ - - /* Point at the byte after the byte we read. */ - current = buf + --len; /* Do the -- outside of macros. */ - - if (memNE(buf, magicstr, len)) { - /* - * Try to read more bytes to check for the old magic number, which - * was longer. - */ - - TRACEME(("trying for old magic number")); - - old_len = sizeof(old_magicstr) - 1; - READ(current + 1, (SSize_t)(old_len - len)); - - if (memNE(buf, old_magicstr, old_len)) - CROAK(("File is not a perl storable")); - old_magic++; - current = buf + old_len; - } - use_network_order = *current; - } else - GETMARK(use_network_order); - - /* - * Starting with 0.6, the "use_network_order" byte flag is also used to - * indicate the version number of the binary, and therefore governs the - * setting of sv_retrieve_vtbl. See magic_write(). - */ - if (old_magic && use_network_order > 1) { - /* 0.1 dump - use_network_order is really byte order length */ - version_major = -1; - } - else { - version_major = use_network_order >> 1; - } - cxt->retrieve_vtbl = (SV*(**)(pTHX_ stcxt_t *cxt, const char *cname)) (version_major > 0 ? sv_retrieve : sv_old_retrieve); - - TRACEME(("magic_check: netorder = 0x%x", use_network_order)); - - - /* - * Starting with 0.7 (binary major 2), a full byte is dedicated to the - * minor version of the protocol. See magic_write(). - */ - - if (version_major > 1) - GETMARK(version_minor); - - cxt->ver_major = version_major; - cxt->ver_minor = version_minor; - - TRACEME(("binary image version is %d.%d", version_major, version_minor)); - - /* - * Inter-operability sanity check: we can't retrieve something stored - * using a format more recent than ours, because we have no way to - * know what has changed, and letting retrieval go would mean a probable - * failure reporting a "corrupted" storable file. - */ - - if ( - version_major > STORABLE_BIN_MAJOR || - (version_major == STORABLE_BIN_MAJOR && - version_minor > STORABLE_BIN_MINOR) - ) { - int croak_now = 1; - TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR, - STORABLE_BIN_MINOR)); - - if (version_major == STORABLE_BIN_MAJOR) { - TRACEME(("cxt->accept_future_minor is %d", - cxt->accept_future_minor)); - if (cxt->accept_future_minor < 0) - cxt->accept_future_minor - = (SvTRUE(perl_get_sv("Storable::accept_future_minor", - GV_ADD)) - ? 1 : 0); - if (cxt->accept_future_minor == 1) - croak_now = 0; /* Don't croak yet. */ - } - if (croak_now) { - CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)", - version_major, version_minor, - STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); - } - } - - /* - * If they stored using network order, there's no byte ordering - * information to check. - */ - - if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */ - return &PL_sv_undef; /* No byte ordering info */ - - /* In C truth is 1, falsehood is 0. Very convienient. */ - use_NV_size = version_major >= 2 && version_minor >= 2; - - if (version_major >= 0) { - GETMARK(c); - } - else { - c = use_network_order; - } - length = c + 3 + use_NV_size; - READ(buf, length); /* Not null-terminated */ - - TRACEME(("byte order '%.*s' %d", c, buf, c)); - -#ifdef USE_56_INTERWORK_KLUDGE - /* No point in caching this in the context as we only need it once per - retrieve, and we need to recheck it each read. */ - if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) { - if ((c != (sizeof (byteorderstr_56) - 1)) - || memNE(buf, byteorderstr_56, c)) - CROAK(("Byte order is not compatible")); - } else -#endif - { - if ((c != (sizeof (byteorderstr) - 1)) || memNE(buf, byteorderstr, c)) - CROAK(("Byte order is not compatible")); - } - - current = buf + c; - - /* sizeof(int) */ - if ((int) *current++ != sizeof(int)) - CROAK(("Integer size is not compatible")); - - /* sizeof(long) */ - if ((int) *current++ != sizeof(long)) - CROAK(("Long integer size is not compatible")); - - /* sizeof(char *) */ - if ((int) *current != sizeof(char *)) - CROAK(("Pointer size is not compatible")); - - if (use_NV_size) { - /* sizeof(NV) */ - if ((int) *++current != sizeof(NV)) - CROAK(("Double size is not compatible")); - } - - return &PL_sv_undef; /* OK */ -} - -/* - * retrieve - * - * Recursively retrieve objects from the specified file and return their - * root SV (which may be an AV or an HV for what we care). - * Returns null if there is a problem. - */ -static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname) -{ - int type; - SV **svh; - SV *sv; - - TRACEME(("retrieve")); - - /* - * Grab address tag which identifies the object if we are retrieving - * an older format. Since the new binary format counts objects and no - * longer explicitely tags them, we must keep track of the correspondance - * ourselves. - * - * The following section will disappear one day when the old format is - * no longer supported, hence the final "goto" in the "if" block. - */ - - if (cxt->hseen) { /* Retrieving old binary */ - stag_t tag; - if (cxt->netorder) { - I32 nettag; - READ(&nettag, sizeof(I32)); /* Ordered sequence of I32 */ - tag = (stag_t) nettag; - } else - READ(&tag, sizeof(stag_t)); /* Original address of the SV */ - - GETMARK(type); - if (type == SX_OBJECT) { - I32 tagn; - svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE); - if (!svh) - CROAK(("Old tag 0x%"UVxf" should have been mapped already", - (UV) tag)); - tagn = SvIV(*svh); /* Mapped tag number computed earlier below */ - - /* - * The following code is common with the SX_OBJECT case below. - */ - - svh = av_fetch(cxt->aseen, tagn, FALSE); - if (!svh) - CROAK(("Object #%"IVdf" should have been retrieved already", - (IV) tagn)); - sv = *svh; - TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv))); - SvREFCNT_inc(sv); /* One more reference to this same sv */ - return sv; /* The SV pointer where object was retrieved */ - } - - /* - * Map new object, but don't increase tagnum. This will be done - * by each of the retrieve_* functions when they call SEEN(). - * - * The mapping associates the "tag" initially present with a unique - * tag number. See test for SX_OBJECT above to see how this is perused. - */ - - if (!hv_store(cxt->hseen, (char *) &tag, sizeof(tag), - newSViv(cxt->tagnum), 0)) - return (SV *) 0; - - goto first_time; - } - - /* - * Regular post-0.6 binary format. - */ - - GETMARK(type); - - TRACEME(("retrieve type = %d", type)); - - /* - * Are we dealing with an object we should have already retrieved? - */ - - if (type == SX_OBJECT) { - I32 tag; - READ_I32(tag); - tag = ntohl(tag); - svh = av_fetch(cxt->aseen, tag, FALSE); - if (!svh) - CROAK(("Object #%"IVdf" should have been retrieved already", - (IV) tag)); - sv = *svh; - TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv))); - SvREFCNT_inc(sv); /* One more reference to this same sv */ - return sv; /* The SV pointer where object was retrieved */ - } else if (type >= SX_ERROR && cxt->ver_minor > STORABLE_BIN_MINOR) { - if (cxt->accept_future_minor < 0) - cxt->accept_future_minor - = (SvTRUE(perl_get_sv("Storable::accept_future_minor", - GV_ADD)) - ? 1 : 0); - if (cxt->accept_future_minor == 1) { - CROAK(("Storable binary image v%d.%d contains data of type %d. " - "This Storable is v%d.%d and can only handle data types up to %d", - cxt->ver_major, cxt->ver_minor, type, - STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_ERROR - 1)); - } - } - -first_time: /* Will disappear when support for old format is dropped */ - - /* - * Okay, first time through for this one. - */ - - sv = RETRIEVE(cxt, type)(aTHX_ cxt, cname); - if (!sv) - return (SV *) 0; /* Failed */ - - /* - * Old binary formats (pre-0.7). - * - * Final notifications, ended by SX_STORED may now follow. - * Currently, the only pertinent notification to apply on the - * freshly retrieved object is either: - * SX_CLASS <char-len> <classname> for short classnames. - * SX_LG_CLASS <int-len> <classname> for larger one (rare!). - * Class name is then read into the key buffer pool used by - * hash table key retrieval. - */ - - if (cxt->ver_major < 2) { - while ((type = GETCHAR()) != SX_STORED) { - I32 len; - switch (type) { - case SX_CLASS: - GETMARK(len); /* Length coded on a single char */ - break; - case SX_LG_CLASS: /* Length coded on a regular integer */ - RLEN(len); - break; - case EOF: - default: - return (SV *) 0; /* Failed */ - } - KBUFCHK((STRLEN)len); /* Grow buffer as necessary */ - if (len) - READ(kbuf, len); - kbuf[len] = '\0'; /* Mark string end */ - BLESS(sv, kbuf); - } - } - - TRACEME(("ok (retrieved 0x%"UVxf", refcnt=%d, %s)", PTR2UV(sv), - SvREFCNT(sv) - 1, sv_reftype(sv, FALSE))); - - return sv; /* Ok */ -} - -/* - * do_retrieve - * - * Retrieve data held in file and return the root object. - * Common routine for pretrieve and mretrieve. - */ -static SV *do_retrieve( - pTHX_ - PerlIO *f, - SV *in, - int optype) -{ - dSTCXT; - SV *sv; - int is_tainted; /* Is input source tainted? */ - int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */ - - TRACEME(("do_retrieve (optype = 0x%x)", optype)); - - optype |= ST_RETRIEVE; - - /* - * Sanity assertions for retrieve dispatch tables. - */ - - ASSERT(sizeof(sv_old_retrieve) == sizeof(sv_retrieve), - ("old and new retrieve dispatch table have same size")); - ASSERT(sv_old_retrieve[SX_ERROR] == retrieve_other, - ("SX_ERROR entry correctly initialized in old dispatch table")); - ASSERT(sv_retrieve[SX_ERROR] == retrieve_other, - ("SX_ERROR entry correctly initialized in new dispatch table")); - - /* - * Workaround for CROAK leak: if they enter with a "dirty" context, - * free up memory for them now. - */ - - if (cxt->s_dirty) - clean_context(aTHX_ cxt); - - /* - * Now that STORABLE_xxx hooks exist, it is possible that they try to - * re-enter retrieve() via the hooks. - */ - - if (cxt->entry) - cxt = allocate_context(aTHX_ cxt); - - cxt->entry++; - - ASSERT(cxt->entry == 1, ("starting new recursion")); - ASSERT(!cxt->s_dirty, ("clean context")); - - /* - * Prepare context. - * - * Data is loaded into the memory buffer when f is NULL, unless `in' is - * also NULL, in which case we're expecting the data to already lie - * in the buffer (dclone case). - */ - - KBUFINIT(); /* Allocate hash key reading pool once */ - - if (!f && in) { -#ifdef SvUTF8_on - if (SvUTF8(in)) { - STRLEN length; - const char *orig = SvPV(in, length); - char *asbytes; - /* This is quite deliberate. I want the UTF8 routines - to encounter the '\0' which perl adds at the end - of all scalars, so that any new string also has - this. - */ - STRLEN klen_tmp = length + 1; - bool is_utf8 = TRUE; - - /* Just casting the &klen to (STRLEN) won't work - well if STRLEN and I32 are of different widths. - --jhi */ - asbytes = (char*)bytes_from_utf8((U8*)orig, - &klen_tmp, - &is_utf8); - if (is_utf8) { - CROAK(("Frozen string corrupt - contains characters outside 0-255")); - } - if (asbytes != orig) { - /* String has been converted. - There is no need to keep any reference to - the old string. */ - in = sv_newmortal(); - /* We donate the SV the malloc()ed string - bytes_from_utf8 returned us. */ - SvUPGRADE(in, SVt_PV); - SvPOK_on(in); - SvPV_set(in, asbytes); - SvLEN_set(in, klen_tmp); - SvCUR_set(in, klen_tmp - 1); - } - } -#endif - MBUF_SAVE_AND_LOAD(in); - } - - /* - * Magic number verifications. - * - * This needs to be done before calling init_retrieve_context() - * since the format indication in the file are necessary to conduct - * some of the initializations. - */ - - cxt->fio = f; /* Where I/O are performed */ - - if (!magic_check(aTHX_ cxt)) - CROAK(("Magic number checking on storable %s failed", - cxt->fio ? "file" : "string")); - - TRACEME(("data stored in %s format", - cxt->netorder ? "net order" : "native")); - - /* - * Check whether input source is tainted, so that we don't wrongly - * taint perfectly good values... - * - * We assume file input is always tainted. If both `f' and `in' are - * NULL, then we come from dclone, and tainted is already filled in - * the context. That's a kludge, but the whole dclone() thing is - * already quite a kludge anyway! -- RAM, 15/09/2000. - */ - - is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted); - TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted")); - init_retrieve_context(aTHX_ cxt, optype, is_tainted); - - ASSERT(is_retrieving(aTHX), ("within retrieve operation")); - - sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */ - - /* - * Final cleanup. - */ - - if (!f && in) - MBUF_RESTORE(); - - pre_06_fmt = cxt->hseen != NULL; /* Before we clean context */ - - /* - * The "root" context is never freed. - */ - - clean_retrieve_context(aTHX_ cxt); - if (cxt->prev) /* This context was stacked */ - free_context(aTHX_ cxt); /* It was not the "root" context */ - - /* - * Prepare returned value. - */ - - if (!sv) { - TRACEME(("retrieve ERROR")); -#if (PATCHLEVEL <= 4) - /* perl 5.00405 seems to screw up at this point with an - 'attempt to modify a read only value' error reported in the - eval { $self = pretrieve(*FILE) } in _retrieve. - I can't see what the cause of this error is, but I suspect a - bug in 5.004, as it seems to be capable of issuing spurious - errors or core dumping with matches on $@. I'm not going to - spend time on what could be a fruitless search for the cause, - so here's a bodge. If you're running 5.004 and don't like - this inefficiency, either upgrade to a newer perl, or you are - welcome to find the problem and send in a patch. - */ - return newSV(0); -#else - return &PL_sv_undef; /* Something went wrong, return undef */ -#endif - } - - TRACEME(("retrieve got %s(0x%"UVxf")", - sv_reftype(sv, FALSE), PTR2UV(sv))); - - /* - * Backward compatibility with Storable-0.5@9 (which we know we - * are retrieving if hseen is non-null): don't create an extra RV - * for objects since we special-cased it at store time. - * - * Build a reference to the SV returned by pretrieve even if it is - * already one and not a scalar, for consistency reasons. - */ - - if (pre_06_fmt) { /* Was not handling overloading by then */ - SV *rv; - TRACEME(("fixing for old formats -- pre 0.6")); - if (sv_type(aTHX_ sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) { - TRACEME(("ended do_retrieve() with an object -- pre 0.6")); - return sv; - } - } - - /* - * If reference is overloaded, restore behaviour. - * - * NB: minor glitch here: normally, overloaded refs are stored specially - * so that we can croak when behaviour cannot be re-installed, and also - * avoid testing for overloading magic at each reference retrieval. - * - * Unfortunately, the root reference is implicitely stored, so we must - * check for possible overloading now. Furthermore, if we don't restore - * overloading, we cannot croak as if the original ref was, because we - * have no way to determine whether it was an overloaded ref or not in - * the first place. - * - * It's a pity that overloading magic is attached to the rv, and not to - * the underlying sv as blessing is. - */ - - if (SvOBJECT(sv)) { - HV *stash = (HV *) SvSTASH(sv); - SV *rv = newRV_noinc(sv); - if (stash && Gv_AMG(stash)) { - SvAMAGIC_on(rv); - TRACEME(("restored overloading on root reference")); - } - TRACEME(("ended do_retrieve() with an object")); - return rv; - } - - TRACEME(("regular do_retrieve() end")); - - return newRV_noinc(sv); -} - -/* - * pretrieve - * - * Retrieve data held in file and return the root object, undef on error. - */ -static SV *pretrieve(pTHX_ PerlIO *f) -{ - TRACEME(("pretrieve")); - return do_retrieve(aTHX_ f, Nullsv, 0); -} - -/* - * mretrieve - * - * Retrieve data held in scalar and return the root object, undef on error. - */ -static SV *mretrieve(pTHX_ SV *sv) -{ - TRACEME(("mretrieve")); - return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0); -} - -/*** - *** Deep cloning - ***/ - -/* - * dclone - * - * Deep clone: returns a fresh copy of the original referenced SV tree. - * - * This is achieved by storing the object in memory and restoring from - * there. Not that efficient, but it should be faster than doing it from - * pure perl anyway. - */ -static SV *dclone(pTHX_ SV *sv) -{ - dSTCXT; - int size; - stcxt_t *real_context; - SV *out; - - TRACEME(("dclone")); - - /* - * Workaround for CROAK leak: if they enter with a "dirty" context, - * free up memory for them now. - */ - - if (cxt->s_dirty) - clean_context(aTHX_ cxt); - - /* - * Tied elements seem to need special handling. - */ - - if ((SvTYPE(sv) == SVt_PVLV -#if PERL_VERSION < 8 - || SvTYPE(sv) == SVt_PVMG -#endif - ) && SvRMAGICAL(sv) && mg_find(sv, 'p')) { - mg_get(sv); - } - - /* - * do_store() optimizes for dclone by not freeing its context, should - * we need to allocate one because we're deep cloning from a hook. - */ - - if (!do_store(aTHX_ (PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0)) - return &PL_sv_undef; /* Error during store */ - - /* - * Because of the above optimization, we have to refresh the context, - * since a new one could have been allocated and stacked by do_store(). - */ - - { dSTCXT; real_context = cxt; } /* Sub-block needed for macro */ - cxt = real_context; /* And we need this temporary... */ - - /* - * Now, `cxt' may refer to a new context. - */ - - ASSERT(!cxt->s_dirty, ("clean context")); - ASSERT(!cxt->entry, ("entry will not cause new context allocation")); - - size = MBUF_SIZE(); - TRACEME(("dclone stored %d bytes", size)); - MBUF_INIT(size); - - /* - * Since we're passing do_retrieve() both a NULL file and sv, we need - * to pre-compute the taintedness of the input by setting cxt->tainted - * to whatever state our own input string was. -- RAM, 15/09/2000 - * - * do_retrieve() will free non-root context. - */ - - cxt->s_tainted = SvTAINTED(sv); - out = do_retrieve(aTHX_ (PerlIO*) 0, Nullsv, ST_CLONE); - - TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out))); - - return out; -} - -/*** - *** Glue with perl. - ***/ - -/* - * The Perl IO GV object distinguishes between input and output for sockets - * but not for plain files. To allow Storable to transparently work on - * plain files and sockets transparently, we have to ask xsubpp to fetch the - * right object for us. Hence the OutputStream and InputStream declarations. - * - * Before perl 5.004_05, those entries in the standard typemap are not - * defined in perl include files, so we do that here. - */ - -#ifndef OutputStream -#define OutputStream PerlIO * -#define InputStream PerlIO * -#endif /* !OutputStream */ - -MODULE = Storable PACKAGE = Storable::Cxt - -void -DESTROY(self) - SV *self -PREINIT: - stcxt_t *cxt = (stcxt_t *)SvPVX(SvRV(self)); -PPCODE: - if (kbuf) - Safefree(kbuf); - if (!cxt->membuf_ro && mbase) - Safefree(mbase); - if (cxt->membuf_ro && (cxt->msaved).arena) - Safefree((cxt->msaved).arena); - - -MODULE = Storable PACKAGE = Storable - -PROTOTYPES: ENABLE - -BOOT: -{ - HV *stash = gv_stashpvn("Storable", 8, GV_ADD); - newCONSTSUB(stash, "BIN_MAJOR", newSViv(STORABLE_BIN_MAJOR)); - newCONSTSUB(stash, "BIN_MINOR", newSViv(STORABLE_BIN_MINOR)); - newCONSTSUB(stash, "BIN_WRITE_MINOR", newSViv(STORABLE_BIN_WRITE_MINOR)); - - init_perinterp(aTHX); - gv_fetchpv("Storable::drop_utf8", GV_ADDMULTI, SVt_PV); -#ifdef DEBUGME - /* Only disable the used only once warning if we are in debugging mode. */ - gv_fetchpv("Storable::DEBUGME", GV_ADDMULTI, SVt_PV); -#endif -#ifdef USE_56_INTERWORK_KLUDGE - gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV); -#endif -} - -void -init_perinterp() - CODE: - init_perinterp(aTHX); - -int -pstore(f,obj) -OutputStream f -SV * obj - CODE: - RETVAL = pstore(aTHX_ f, obj); - OUTPUT: - RETVAL - -int -net_pstore(f,obj) -OutputStream f -SV * obj - CODE: - RETVAL = net_pstore(aTHX_ f, obj); - OUTPUT: - RETVAL - -SV * -mstore(obj) -SV * obj - CODE: - RETVAL = mstore(aTHX_ obj); - OUTPUT: - RETVAL - -SV * -net_mstore(obj) -SV * obj - CODE: - RETVAL = net_mstore(aTHX_ obj); - OUTPUT: - RETVAL - -SV * -pretrieve(f) -InputStream f - CODE: - RETVAL = pretrieve(aTHX_ f); - OUTPUT: - RETVAL - -SV * -mretrieve(sv) -SV * sv - CODE: - RETVAL = mretrieve(aTHX_ sv); - OUTPUT: - RETVAL - -SV * -dclone(sv) -SV * sv - CODE: - RETVAL = dclone(aTHX_ sv); - OUTPUT: - RETVAL - -int -last_op_in_netorder() - CODE: - RETVAL = last_op_in_netorder(aTHX); - OUTPUT: - RETVAL - -int -is_storing() - CODE: - RETVAL = is_storing(aTHX); - OUTPUT: - RETVAL - -int -is_retrieving() - CODE: - RETVAL = is_retrieving(aTHX); - OUTPUT: - RETVAL diff --git a/ext/Storable/hints/gnukfreebsd.pl b/ext/Storable/hints/gnukfreebsd.pl deleted file mode 100644 index db63567966..0000000000 --- a/ext/Storable/hints/gnukfreebsd.pl +++ /dev/null @@ -1 +0,0 @@ -do './hints/linux.pl' or die $@; diff --git a/ext/Storable/hints/gnuknetbsd.pl b/ext/Storable/hints/gnuknetbsd.pl deleted file mode 100644 index db63567966..0000000000 --- a/ext/Storable/hints/gnuknetbsd.pl +++ /dev/null @@ -1 +0,0 @@ -do './hints/linux.pl' or die $@; diff --git a/ext/Storable/hints/hpux.pl b/ext/Storable/hints/hpux.pl deleted file mode 100644 index 959d6fedf0..0000000000 --- a/ext/Storable/hints/hpux.pl +++ /dev/null @@ -1,10 +0,0 @@ -# HP C-ANSI-C has problems in the optimizer for 5.8.x (not for 5.11.x) -# So drop to -O1 for Storable - -use Config; - -unless ($Config{gccversion}) { - my $optimize = $Config{optimize}; - $optimize =~ s/(^| )[-+]O[2-9]( |$)/$1+O1$2/ and - $self->{OPTIMIZE} = $optimize; - } diff --git a/ext/Storable/hints/linux.pl b/ext/Storable/hints/linux.pl deleted file mode 100644 index 0c7d5e35a9..0000000000 --- a/ext/Storable/hints/linux.pl +++ /dev/null @@ -1,15 +0,0 @@ -# gcc -O3 (and higher) can cause code produced from Storable.xs that -# dumps core immediately in recurse.t and retrieve.t, in is_storing() -# and last_op_in_netorder(), respectively. In both cases the cxt is -# full of junk (and according to valgrind the cxt was never stack'd, -# malloc'd or free'd). Observed in Debian 3.0 x86, with gccs 2.95.4 -# 20011002 and 3.3, and in Redhat 7.1 with gcc 3.3.1. The failures -# happen only for unthreaded builds, threaded builds work okay. -use Config; -if ($Config{gccversion}) { - my $optimize = $Config{optimize}; - if ($optimize =~ s/(^| )-O[3-9]( |$)/$1-O2$2/) { - $self->{OPTIMIZE} = $optimize; - } -} - diff --git a/ext/Storable/t/HAS_ATTACH.pm b/ext/Storable/t/HAS_ATTACH.pm deleted file mode 100644 index 72855aa101..0000000000 --- a/ext/Storable/t/HAS_ATTACH.pm +++ /dev/null @@ -1,10 +0,0 @@ -package HAS_ATTACH; - -sub STORABLE_attach { - ++$attached_count; - return bless [], 'HAS_ATTACH'; -} - -++$loaded_count; - -1; diff --git a/ext/Storable/t/HAS_HOOK.pm b/ext/Storable/t/HAS_HOOK.pm deleted file mode 100644 index 979a6a207d..0000000000 --- a/ext/Storable/t/HAS_HOOK.pm +++ /dev/null @@ -1,9 +0,0 @@ -package HAS_HOOK; - -sub STORABLE_thaw { - ++$thawed_count; -} - -++$loaded_count; - -1; diff --git a/ext/Storable/t/HAS_OVERLOAD.pm b/ext/Storable/t/HAS_OVERLOAD.pm deleted file mode 100644 index 8a622a4bbe..0000000000 --- a/ext/Storable/t/HAS_OVERLOAD.pm +++ /dev/null @@ -1,14 +0,0 @@ -package HAS_OVERLOAD; - -use overload - '""' => sub { ${$_[0]} }, fallback => 1; - -sub make { - my $package = shift; - my $value = shift; - bless \$value, $package; -} - -++$loaded_count; - -1; diff --git a/ext/Storable/t/attach_errors.t b/ext/Storable/t/attach_errors.t deleted file mode 100644 index ffa41f9138..0000000000 --- a/ext/Storable/t/attach_errors.t +++ /dev/null @@ -1,264 +0,0 @@ -#!./perl -w -# -# Copyright 2005, Adam Kennedy. -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -# Man, blessed.t scared the hell out of me. For a second there I thought -# I'd lose Test::More... - -# This file tests several known-error cases relating to STORABLE_attach, in -# which Storable should (correctly) throw errors. - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use Test::More tests => 35; -use Storable (); - - - - - -##################################################################### -# Error 1 -# -# Classes that implement STORABLE_thaw _cannot_ have references -# returned by their STORABLE_freeze method. When they do, Storable -# should throw an exception - - - -# Good Case - should not die -{ - my $goodfreeze = bless {}, 'My::GoodFreeze'; - my $frozen = undef; - eval { - $frozen = Storable::freeze( $goodfreeze ); - }; - ok( ! $@, 'Storable does not die when STORABLE_freeze does not return references' ); - ok( $frozen, 'Storable freezes to a string successfully' ); - - package My::GoodFreeze; - - sub STORABLE_freeze { - my ($self, $clone) = @_; - - # Illegally include a reference in this return - return (''); - } - - sub STORABLE_attach { - my ($class, $clone, $string) = @_; - return bless { }, 'My::GoodFreeze'; - } -} - - - -# Error Case - should die on freeze -{ - my $badfreeze = bless {}, 'My::BadFreeze'; - eval { - Storable::freeze( $badfreeze ); - }; - ok( $@, 'Storable dies correctly when STORABLE_freeze returns a referece' ); - # Check for a unique substring of the error message - ok( $@ =~ /cannot return references/, 'Storable dies with the expected error' ); - - package My::BadFreeze; - - sub STORABLE_freeze { - my ($self, $clone) = @_; - - # Illegally include a reference in this return - return ('', []); - } - - sub STORABLE_attach { - my ($class, $clone, $string) = @_; - return bless { }, 'My::BadFreeze'; - } -} - - - - - -##################################################################### -# Error 2 -# -# If, for some reason, a STORABLE_attach object is accidentally stored -# with references, this should be checked and and error should be throw. - - - -# Good Case - should not die -{ - my $goodthaw = bless {}, 'My::GoodThaw'; - my $frozen = undef; - eval { - $frozen = Storable::freeze( $goodthaw ); - }; - ok( $frozen, 'Storable freezes to a string as expected' ); - my $thawed = eval { - Storable::thaw( $frozen ); - }; - isa_ok( $thawed, 'My::GoodThaw' ); - is( $thawed->{foo}, 'bar', 'My::GoodThaw thawed correctly as expected' ); - - package My::GoodThaw; - - sub STORABLE_freeze { - my ($self, $clone) = @_; - - return (''); - } - - sub STORABLE_attach { - my ($class, $clone, $string) = @_; - return bless { 'foo' => 'bar' }, 'My::GoodThaw'; - } -} - - - -# Bad Case - should die on thaw -{ - # Create the frozen string normally - my $badthaw = bless { }, 'My::BadThaw'; - my $frozen = undef; - eval { - $frozen = Storable::freeze( $badthaw ); - }; - ok( $frozen, 'BadThaw was frozen with references correctly' ); - - # Set up the error condition by deleting the normal STORABLE_thaw, - # and creating a STORABLE_attach. - *My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw; - *My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw; # Suppress a warning - delete ${'My::BadThaw::'}{STORABLE_thaw}; - - # Trigger the error condition - my $thawed = undef; - eval { - $thawed = Storable::thaw( $frozen ); - }; - ok( $@, 'My::BadThaw object dies when thawing as expected' ); - # Check for a snippet from the error message - ok( $@ =~ /unexpected references/, 'Dies with the expected error message' ); - - package My::BadThaw; - - sub STORABLE_freeze { - my ($self, $clone) = @_; - - return ('', []); - } - - # Start with no STORABLE_attach method so we can get a - # frozen object-containing-a-reference into the freeze string. - sub STORABLE_thaw { - my ($class, $clone, $string) = @_; - return bless { 'foo' => 'bar' }, 'My::BadThaw'; - } -} - - - - -##################################################################### -# Error 3 -# -# Die if what is returned by STORABLE_attach is not something of that class - - - -# Good Case - should not die -{ - my $goodattach = bless { }, 'My::GoodAttach'; - my $frozen = Storable::freeze( $goodattach ); - ok( $frozen, 'My::GoodAttach return as expected' ); - my $thawed = eval { - Storable::thaw( $frozen ); - }; - isa_ok( $thawed, 'My::GoodAttach' ); - is( ref($thawed), 'My::GoodAttach::Subclass', - 'The slightly-tricky good "returns a subclass" case returns as expected' ); - - package My::GoodAttach; - - sub STORABLE_freeze { - my ($self, $cloning) = @_; - return (''); - } - - sub STORABLE_attach { - my ($class, $cloning, $string) = @_; - - return bless { }, 'My::GoodAttach::Subclass'; - } - - package My::GoodAttach::Subclass; - - BEGIN { - @ISA = 'My::GoodAttach'; - } -} - - - -# Bad Cases - die on thaw -{ - my $returnvalue = undef; - - # Create and freeze the object - my $badattach = bless { }, 'My::BadAttach'; - my $frozen = Storable::freeze( $badattach ); - ok( $frozen, 'BadAttach freezes as expected' ); - - # Try a number of different return values, all of which - # should cause Storable to die. - my @badthings = ( - undef, - '', - 1, - [], - {}, - \"foo", - (bless { }, 'Foo'), - ); - foreach ( @badthings ) { - $returnvalue = $_; - - my $thawed = undef; - eval { - $thawed = Storable::thaw( $frozen ); - }; - ok( $@, 'BadAttach dies on thaw' ); - ok( $@ =~ /STORABLE_attach did not return a My::BadAttach object/, - 'BadAttach dies on thaw with the expected error message' ); - is( $thawed, undef, 'Double checking $thawed was not set' ); - } - - package My::BadAttach; - - sub STORABLE_freeze { - my ($self, $cloning) = @_; - return (''); - } - - sub STORABLE_attach { - my ($class, $cloning, $string) = @_; - - return $returnvalue; - } -} diff --git a/ext/Storable/t/attach_singleton.t b/ext/Storable/t/attach_singleton.t deleted file mode 100644 index e850a16f9c..0000000000 --- a/ext/Storable/t/attach_singleton.t +++ /dev/null @@ -1,84 +0,0 @@ -#!./perl -w -# -# Copyright 2005, Adam Kennedy. -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -# Tests freezing/thawing structures containing Singleton objects, -# which should see both structs pointing to the same object. - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use Test::More tests => 11; -use Storable (); - -# Get the singleton -my $object = My::Singleton->new; -isa_ok( $object, 'My::Singleton' ); - -# Confirm (for the record) that the class is actually a Singleton -my $object2 = My::Singleton->new; -isa_ok( $object2, 'My::Singleton' ); -is( "$object", "$object2", 'Class is a singleton' ); - -############ -# Main Tests - -my $struct = [ 1, $object, 3 ]; - -# Freeze the struct -my $frozen = Storable::freeze( $struct ); -ok( (defined($frozen) and ! ref($frozen) and length($frozen)), 'freeze returns a string' ); - -# Thaw the struct -my $thawed = Storable::thaw( $frozen ); - -# Now it should look exactly like the original -is_deeply( $struct, $thawed, 'Struct superficially looks like the original' ); - -# ... EXCEPT that the Singleton should be the same instance of the object -is( "$struct->[1]", "$thawed->[1]", 'Singleton thaws correctly' ); - -# We can also test this empirically -$struct->[1]->{value} = 'Goodbye cruel world!'; -is_deeply( $struct, $thawed, 'Empiric testing corfirms correct behaviour' ); - -# End Tests -########### - -package My::Singleton; - -my $SINGLETON = undef; - -sub new { - $SINGLETON or - $SINGLETON = bless { value => 'Hello World!' }, $_[0]; -} - -sub STORABLE_freeze { - my $self = shift; - - # We don't actually need to return anything, but provide a null string - # to avoid the null-list-return behaviour. - return ('foo'); -} - -sub STORABLE_attach { - my ($class, $clone, $string) = @_; - Test::More::ok( ! ref $class, 'STORABLE_attach passed class, and not an object' ); - Test::More::is( $class, 'My::Singleton', 'STORABLE_attach is passed the correct class name' ); - Test::More::is( $clone, 0, 'We are not in a dclone' ); - Test::More::is( $string, 'foo', 'STORABLE_attach gets the string back' ); - - # Get the Singleton object and return it - return $class->new; -} diff --git a/ext/Storable/t/blessed.t b/ext/Storable/t/blessed.t deleted file mode 100644 index 7c0494c840..0000000000 --- a/ext/Storable/t/blessed.t +++ /dev/null @@ -1,195 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw); - -%::immortals - = (u => \undef, - 'y' => \(1 == 1), - n => \(1 == 0) -); - -my $test = 12; -my $tests = $test + 6 + 2 * 6 * keys %::immortals; -print "1..$tests\n"; - -package SHORT_NAME; - -sub make { bless [], shift } - -package SHORT_NAME_WITH_HOOK; - -sub make { bless [], shift } - -sub STORABLE_freeze { - my $self = shift; - return ("", $self); -} - -sub STORABLE_thaw { - my $self = shift; - my $cloning = shift; - my ($x, $obj) = @_; - die "STORABLE_thaw" unless $obj eq $self; -} - -package main; - -# Still less than 256 bytes, so long classname logic not fully exercised -# Wait until Perl removes the restriction on identifier lengths. -my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final"; - -eval <<EOC; -package $name; - -\@ISA = ("SHORT_NAME"); -EOC -die $@ if $@; -ok 1, $@ eq ''; - -eval <<EOC; -package ${name}_WITH_HOOK; - -\@ISA = ("SHORT_NAME_WITH_HOOK"); -EOC -ok 2, $@ eq ''; - -# Construct a pool of objects -my @pool; - -for (my $i = 0; $i < 10; $i++) { - push(@pool, SHORT_NAME->make); - push(@pool, SHORT_NAME_WITH_HOOK->make); - push(@pool, $name->make); - push(@pool, "${name}_WITH_HOOK"->make); -} - -my $x = freeze \@pool; -ok 3, 1; - -my $y = thaw $x; -ok 4, ref $y eq 'ARRAY'; -ok 5, @{$y} == @pool; - -ok 6, ref $y->[0] eq 'SHORT_NAME'; -ok 7, ref $y->[1] eq 'SHORT_NAME_WITH_HOOK'; -ok 8, ref $y->[2] eq $name; -ok 9, ref $y->[3] eq "${name}_WITH_HOOK"; - -my $good = 1; -for (my $i = 0; $i < 10; $i++) { - do { $good = 0; last } unless ref $y->[4*$i] eq 'SHORT_NAME'; - do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK'; - do { $good = 0; last } unless ref $y->[4*$i+2] eq $name; - do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK"; -} -ok 10, $good; - -{ - my $blessed_ref = bless \\[1,2,3], 'Foobar'; - my $x = freeze $blessed_ref; - my $y = thaw $x; - ok 11, ref $y eq 'Foobar'; - ok 12, $$$y->[0] == 1; -} - -package RETURNS_IMMORTALS; - -sub make { my $self = shift; bless [@_], $self } - -sub STORABLE_freeze { - # Some reference some number of times. - my $self = shift; - my ($what, $times) = @$self; - return ("$what$times", ($::immortals{$what}) x $times); -} - -sub STORABLE_thaw { - my $self = shift; - my $cloning = shift; - my ($x, @refs) = @_; - my ($what, $times) = $x =~ /(.)(\d+)/; - die "'$x' didn't match" unless defined $times; - main::ok ++$test, @refs == $times; - my $expect = $::immortals{$what}; - die "'$x' did not give a reference" unless ref $expect; - my $fail; - foreach (@refs) { - $fail++ if $_ != $expect; - } - main::ok ++$test, !$fail; -} - -package main; - -# $Storable::DEBUGME = 1; -my $count; -foreach $count (1..3) { - my $immortal; - foreach $immortal (keys %::immortals) { - print "# $immortal x $count\n"; - my $i = RETURNS_IMMORTALS->make ($immortal, $count); - - my $f = freeze ($i); - ok ++$test, $f; - my $t = thaw $f; - ok ++$test, 1; - } -} - -# Test automatic require of packages to find thaw hook. - -package HAS_HOOK; - -$loaded_count = 0; -$thawed_count = 0; - -sub make { - bless []; -} - -sub STORABLE_freeze { - my $self = shift; - return ''; -} - -package main; - -my $f = freeze (HAS_HOOK->make); - -ok ++$test, $HAS_HOOK::loaded_count == 0; -ok ++$test, $HAS_HOOK::thawed_count == 0; - -my $t = thaw $f; -ok ++$test, $HAS_HOOK::loaded_count == 1; -ok ++$test, $HAS_HOOK::thawed_count == 1; -ok ++$test, $t; -ok ++$test, ref $t eq 'HAS_HOOK'; - -# Can't do this because the method is still cached by UNIVERSAL::can -# delete $INC{"HAS_HOOK.pm"}; -# undef &HAS_HOOK::STORABLE_thaw; -# -# warn HAS_HOOK->can('STORABLE_thaw'); -# $t = thaw $f; -# ok ++$test, $HAS_HOOK::loaded_count == 2; -# ok ++$test, $HAS_HOOK::thawed_count == 2; -# ok ++$test, $t; -# ok ++$test, ref $t eq 'HAS_HOOK'; diff --git a/ext/Storable/t/canonical.t b/ext/Storable/t/canonical.t deleted file mode 100644 index 204a2359b6..0000000000 --- a/ext/Storable/t/canonical.t +++ /dev/null @@ -1,144 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - - -use Storable qw(freeze thaw dclone); -use vars qw($debugging $verbose); - -print "1..8\n"; - -sub ok { - my($testno, $ok) = @_; - print "not " unless $ok; - print "ok $testno\n"; -} - - -# Uncomment the folowing line to get a dump of the constructed data structure -# (you may want to reduce the size of the hashes too) -# $debugging = 1; - -$hashsize = 100; -$maxhash2size = 100; -$maxarraysize = 100; - -# Use MD5 if its available to make random string keys - -eval { require "MD5.pm" }; -$gotmd5 = !$@; - -# Use Data::Dumper if debugging and it is available to create an ASCII dump - -if ($debugging) { - eval { require "Data/Dumper.pm" }; - $gotdd = !$@; -} - -@fixed_strings = ("January", "February", "March", "April", "May", "June", - "July", "August", "September", "October", "November", "December" ); - -# Build some arbitrarily complex data structure starting with a top level hash -# (deeper levels contain scalars, references to hashes or references to arrays); - -for (my $i = 0; $i < $hashsize; $i++) { - my($k) = int(rand(1_000_000)); - $k = MD5->hexhash($k) if $gotmd5 and int(rand(2)); - $a1{$k} = { key => "$k", "value" => $i }; - - # A third of the elements are references to further hashes - - if (int(rand(1.5))) { - my($hash2) = {}; - my($hash2size) = int(rand($maxhash2size)); - while ($hash2size--) { - my($k2) = $k . $i . int(rand(100)); - $hash2->{$k2} = $fixed_strings[rand(int(@fixed_strings))]; - } - $a1{$k}->{value} = $hash2; - } - - # A further third are references to arrays - - elsif (int(rand(2))) { - my($arr_ref) = []; - my($arraysize) = int(rand($maxarraysize)); - while ($arraysize--) { - push(@$arr_ref, $fixed_strings[rand(int(@fixed_strings))]); - } - $a1{$k}->{value} = $arr_ref; - } -} - - -print STDERR Data::Dumper::Dumper(\%a1) if ($verbose and $gotdd); - - -# Copy the hash, element by element in order of the keys - -foreach $k (sort keys %a1) { - $a2{$k} = { key => "$k", "value" => $a1{$k}->{value} }; -} - -# Deep clone the hash - -$a3 = dclone(\%a1); - -# In canonical mode the frozen representation of each of the hashes -# should be identical - -$Storable::canonical = 1; - -$x1 = freeze(\%a1); -$x2 = freeze(\%a2); -$x3 = freeze($a3); - -ok 1, (length($x1) > $hashsize); # sanity check -ok 2, length($x1) == length($x2); # idem -ok 3, $x1 eq $x2; -ok 4, $x1 eq $x3; - -# In normal mode it is exceedingly unlikely that the frozen -# representaions of all the hashes will be the same (normally the hash -# elements are frozen in the order they are stored internally, -# i.e. pseudo-randomly). - -$Storable::canonical = 0; - -$x1 = freeze(\%a1); -$x2 = freeze(\%a2); -$x3 = freeze($a3); - - -# Two out of three the same may be a coincidence, all three the same -# is much, much more unlikely. Still it could happen, so this test -# may report a false negative. - -ok 5, ($x1 ne $x2) || ($x1 ne $x3); - - -# Ensure refs to "undef" values are properly shared -# Same test as in t/dclone.t to ensure the "canonical" code is also correct - -my $hash; -push @{$$hash{''}}, \$$hash{a}; -ok 6, $$hash{''}[0] == \$$hash{a}; - -my $cloned = dclone(dclone($hash)); -ok 7, $$cloned{''}[0] == \$$cloned{a}; - -$$cloned{a} = "blah"; -ok 8, $$cloned{''}[0] == \$$cloned{a}; diff --git a/ext/Storable/t/circular_hook.t b/ext/Storable/t/circular_hook.t deleted file mode 100644 index 48f4be403d..0000000000 --- a/ext/Storable/t/circular_hook.t +++ /dev/null @@ -1,86 +0,0 @@ -#!./perl -w -# -# Copyright 2005, Adam Kennedy. -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -# Man, blessed.t scared the hell out of me. For a second there I thought -# I'd lose Test::More... - -# This file tests several known-error cases relating to STORABLE_attach, in -# which Storable should (correctly) throw errors. - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use Storable (); -use Test::More tests => 9; - -my $ddd = bless { }, 'Foo'; -my $eee = bless { Bar => $ddd }, 'Bar'; -$ddd->{Foo} = $eee; - -my $array = [ $ddd ]; - -my $string = Storable::freeze( $array ); -my $thawed = Storable::thaw( $string ); - -# is_deeply infinite loops in ciculars, so do it manually -# is_deeply( $array, $thawed, 'Circular hooked objects work' ); -is( ref($thawed), 'ARRAY', 'Top level ARRAY' ); -is( scalar(@$thawed), 1, 'ARRAY contains one element' ); -isa_ok( $thawed->[0], 'Foo' ); -is( scalar(keys %{$thawed->[0]}), 1, 'Foo contains one element' ); -isa_ok( $thawed->[0]->{Foo}, 'Bar' ); -is( scalar(keys %{$thawed->[0]->{Foo}}), 1, 'Bar contains one element' ); -isa_ok( $thawed->[0]->{Foo}->{Bar}, 'Foo' ); -is( $thawed->[0], $thawed->[0]->{Foo}->{Bar}, 'Circular is... well... circular' ); - -# Make sure the thawing went the way we expected -is_deeply( \@Foo::order, [ 'Bar', 'Foo' ], 'thaw order is correct (depth first)' ); - - - - - -package Foo; - -@order = (); - -sub STORABLE_freeze { - my ($self, $clone) = @_; - my $class = ref $self; - - # print "# Freezing $class\n"; - - return ($class, $self->{$class}); -} - -sub STORABLE_thaw { - my ($self, $clone, $string, @refs) = @_; - my $class = ref $self; - - # print "# Thawing $class\n"; - - $self->{$class} = shift @refs; - - push @order, $class; - - return; -} - -package Bar; - -BEGIN { -@ISA = 'Foo'; -} - -1; diff --git a/ext/Storable/t/code.t b/ext/Storable/t/code.t deleted file mode 100644 index dd2a96ec1b..0000000000 --- a/ext/Storable/t/code.t +++ /dev/null @@ -1,307 +0,0 @@ -#!./perl -# -# Copyright (c) 2002 Slaven Rezic -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use strict; -BEGIN { - if (!eval q{ - use Test; - use B::Deparse 0.61; - use 5.006; - 1; - }) { - print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n"; - exit; - } - require File::Spec; - if ($File::Spec::VERSION < 0.8) { - print "1..0 # Skip: newer File::Spec needed\n"; - exit 0; - } -} - -BEGIN { plan tests => 59 } - -use Storable qw(retrieve store nstore freeze nfreeze thaw dclone); -use Safe; - -#$Storable::DEBUGME = 1; - -use vars qw($freezed $thawed @obj @res $blessed_code); - -$blessed_code = bless sub { "blessed" }, "Some::Package"; -{ package Another::Package; sub foo { __PACKAGE__ } } - -{ - no strict; # to make the life for Safe->reval easier - sub code { "JAPH" } -} - -local *FOO; - -@obj = - ([\&code, # code reference - sub { 6*7 }, - $blessed_code, # blessed code reference - \&Another::Package::foo, # code in another package - sub ($$;$) { 0 }, # prototypes - sub { print "test\n" }, - \&Test::ok, # large scalar - ], - - {"a" => sub { "srt" }, "b" => \&code}, - - sub { ord("a")-ord("7") }, - - \&code, - - \&dclone, # XS function - - sub { open FOO, "/" }, - ); - -$Storable::Deparse = 1; -$Storable::Eval = 1; - -###################################################################### -# Test freeze & thaw - -$freezed = freeze $obj[0]; -$thawed = thaw $freezed; - -ok($thawed->[0]->(), "JAPH"); -ok($thawed->[1]->(), 42); -ok($thawed->[2]->(), "blessed"); -ok($thawed->[3]->(), "Another::Package"); -ok(prototype($thawed->[4]), prototype($obj[0]->[4])); - -###################################################################### - -$freezed = freeze $obj[1]; -$thawed = thaw $freezed; - -ok($thawed->{"a"}->(), "srt"); -ok($thawed->{"b"}->(), "JAPH"); - -###################################################################### - -$freezed = freeze $obj[2]; -$thawed = thaw $freezed; - -ok($thawed->(), 42); - -###################################################################### - -$freezed = freeze $obj[3]; -$thawed = thaw $freezed; - -ok($thawed->(), "JAPH"); - -###################################################################### - -eval { $freezed = freeze $obj[4] }; -ok($@, qr/The result of B::Deparse::coderef2text was empty/); - -###################################################################### -# Test dclone - -my $new_sub = dclone($obj[2]); -ok($new_sub->(), $obj[2]->()); - -###################################################################### -# Test retrieve & store - -store $obj[0], 'store'; -$thawed = retrieve 'store'; - -ok($thawed->[0]->(), "JAPH"); -ok($thawed->[1]->(), 42); -ok($thawed->[2]->(), "blessed"); -ok($thawed->[3]->(), "Another::Package"); -ok(prototype($thawed->[4]), prototype($obj[0]->[4])); - -###################################################################### - -nstore $obj[0], 'store'; -$thawed = retrieve 'store'; -unlink 'store'; - -ok($thawed->[0]->(), "JAPH"); -ok($thawed->[1]->(), 42); -ok($thawed->[2]->(), "blessed"); -ok($thawed->[3]->(), "Another::Package"); -ok(prototype($thawed->[4]), prototype($obj[0]->[4])); - -###################################################################### -# Security with -# $Storable::Eval -# $Storable::Deparse - -{ - local $Storable::Eval = 0; - - for my $i (0 .. 1) { - $freezed = freeze $obj[$i]; - $@ = ""; - eval { $thawed = thaw $freezed }; - ok($@, qr/Can\'t eval/); - } -} - -{ - - local $Storable::Deparse = 0; - for my $i (0 .. 1) { - $@ = ""; - eval { $freezed = freeze $obj[$i] }; - ok($@, qr/Can\'t store CODE items/); - } -} - -{ - local $Storable::Eval = 0; - local $Storable::forgive_me = 1; - for my $i (0 .. 4) { - $freezed = freeze $obj[0]->[$i]; - $@ = ""; - eval { $thawed = thaw $freezed }; - ok($@, ""); - ok($$thawed, qr/^sub/); - } -} - -{ - local $Storable::Deparse = 0; - local $Storable::forgive_me = 1; - - my $devnull = File::Spec->devnull; - - open(SAVEERR, ">&STDERR"); - open(STDERR, ">$devnull") or - ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); - - eval { $freezed = freeze $obj[0]->[0] }; - - open(STDERR, ">&SAVEERR"); - - ok($@, ""); - ok($freezed ne ''); -} - -{ - my $safe = new Safe; - local $Storable::Eval = sub { $safe->reval(shift) }; - - $freezed = freeze $obj[0]->[0]; - $@ = ""; - eval { $thawed = thaw $freezed }; - ok($@, ""); - ok($thawed->(), "JAPH"); - - $freezed = freeze $obj[0]->[6]; - eval { $thawed = thaw $freezed }; - # The "Code sub ..." error message only appears if Log::Agent is installed - ok($@, qr/(trapped|Code sub)/); - - if (0) { - # Disable or fix this test if the internal representation of Storable - # changes. - skip("no malicious storable file check", 1); - } else { - # Construct malicious storable code - $freezed = nfreeze $obj[0]->[0]; - my $bad_code = ';open FOO, "/badfile"'; - # 5th byte is (short) length of scalar - my $len = ord(substr($freezed, 4, 1)); - substr($freezed, 4, 1, chr($len+length($bad_code))); - substr($freezed, -1, 0, $bad_code); - $@ = ""; - eval { $thawed = thaw $freezed }; - ok($@, qr/(trapped|Code sub)/); - } -} - -{ - my $safe = new Safe; - # because of opcodes used in "use strict": - $safe->permit(qw(:default require caller)); - local $Storable::Eval = sub { $safe->reval(shift) }; - - $freezed = freeze $obj[0]->[1]; - $@ = ""; - eval { $thawed = thaw $freezed }; - ok($@, ""); - ok($thawed->(), 42); -} - -{ - { - package MySafe; - sub new { bless {}, shift } - sub reval { - my $source = $_[1]; - # Here you can apply some nifty regexpes to ensure the - # safeness of the source code. - my $coderef = eval $source; - $coderef; - } - } - - my $safe = new MySafe; - local $Storable::Eval = sub { $safe->reval($_[0]) }; - - $freezed = freeze $obj[0]; - eval { $thawed = thaw $freezed }; - ok($@, ""); - - if ($@ ne "") { - ok(0) for (1..5); - } else { - ok($thawed->[0]->(), "JAPH"); - ok($thawed->[1]->(), 42); - ok($thawed->[2]->(), "blessed"); - ok($thawed->[3]->(), "Another::Package"); - ok(prototype($thawed->[4]), prototype($obj[0]->[4])); - } -} - -{ - # Check internal "seen" code - my $short_sub = sub { "short sub" }; # for SX_SCALAR - # for SX_LSCALAR - my $long_sub_code = 'sub { "' . "x"x255 . '" }'; - my $long_sub = eval $long_sub_code; die $@ if $@; - my $sclr = \1; - - local $Storable::Deparse = 1; - local $Storable::Eval = 1; - - for my $sub ($short_sub, $long_sub) { - my $res; - - $res = thaw freeze [$sub, $sub]; - ok(int($res->[0]), int($res->[1])); - - $res = thaw freeze [$sclr, $sub, $sub, $sclr]; - ok(int($res->[0]), int($res->[3])); - ok(int($res->[1]), int($res->[2])); - - $res = thaw freeze [$sub, $sub, $sclr, $sclr]; - ok(int($res->[0]), int($res->[1])); - ok(int($res->[2]), int($res->[3])); - } - -} diff --git a/ext/Storable/t/compat01.t b/ext/Storable/t/compat01.t deleted file mode 100644 index 9b472128ce..0000000000 --- a/ext/Storable/t/compat01.t +++ /dev/null @@ -1,51 +0,0 @@ -#!perl -w - -BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - - use Config; - if ($Config{byteorder} ne "1234") { - print "1..0 # Skip: Test only works for 32 bit little-ending machines\n"; - exit 0; - } -} - -use strict; -use Storable qw(retrieve); - -my $file = "xx-$$.pst"; -my @dumps = ( - # some sample dumps of the hash { one => 1 } - "perl-store\x041234\4\4\4\x94y\22\b\3\1\0\0\0vxz\22\b\1\1\0\0\x001Xk\3\0\0\0oneX", # 0.1 - "perl-store\0\x041234\4\4\4\x94y\22\b\3\1\0\0\0vxz\22\b\b\x81Xk\3\0\0\0oneX", # 0.4@7 -); - -print "1.." . @dumps . "\n"; - -my $testno; -for my $dump (@dumps) { - $testno++; - - open(FH, ">$file") || die "Can't create $file: $!"; - binmode(FH); - print FH $dump; - close(FH) || die "Can't write $file: $!"; - - eval { - my $data = retrieve($file); - if (ref($data) eq "HASH" && $data->{one} eq "1") { - print "ok $testno\n"; - } - else { - print "not ok $testno\n"; - } - }; - warn $@ if $@; - - unlink($file); -} diff --git a/ext/Storable/t/compat06.t b/ext/Storable/t/compat06.t deleted file mode 100644 index 6d8ade3dbf..0000000000 --- a/ext/Storable/t/compat06.t +++ /dev/null @@ -1,146 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - -sub ok; - -print "1..8\n"; - -use Storable qw(freeze nfreeze thaw); - -package TIED_HASH; - -sub TIEHASH { - my $self = bless {}, shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($key) = @_; - $main::hash_fetch++; - return $self->{$key}; -} - -sub STORE { - my $self = shift; - my ($key, $val) = @_; - $self->{$key} = $val; -} - -package SIMPLE; - -sub make { - my $self = bless [], shift; - my ($x) = @_; - $self->[0] = $x; - return $self; -} - -package ROOT; - -sub make { - my $self = bless {}, shift; - my $h = tie %hash, TIED_HASH; - $self->{h} = $h; - $self->{ref} = \%hash; - my @pool; - for (my $i = 0; $i < 5; $i++) { - push(@pool, SIMPLE->make($i)); - } - $self->{obj} = \@pool; - my @a = ('string', $h, $self); - $self->{a} = \@a; - $self->{num} = [1, 0, -3, -3.14159, 456, 4.5]; - $h->{key1} = 'val1'; - $h->{key2} = 'val2'; - return $self; -}; - -sub num { $_[0]->{num} } -sub h { $_[0]->{h} } -sub ref { $_[0]->{ref} } -sub obj { $_[0]->{obj} } - -package main; - -my $is_EBCDIC = (ord('A') == 193) ? 1 : 0; - -my $r = ROOT->make; - -my $data = ''; -if (!$is_EBCDIC) { # ASCII machine - while (<DATA>) { - next if /^#/; - $data .= unpack("u", $_); - } -} else { - while (<DATA>) { - next if /^#$/; # skip comments - next if /^#\s+/; # skip comments - next if /^[^#]/; # skip uuencoding for ASCII machines - s/^#//; # prepare uuencoded data for EBCDIC machines - $data .= unpack("u", $_); - } -} - -my $expected_length = $is_EBCDIC ? 217 : 278; -ok 1, length $data == $expected_length; - -my $y = thaw($data); -ok 2, 1; -ok 3, ref $y eq 'ROOT'; - -$Storable::canonical = 1; # Prevent "used once" warning -$Storable::canonical = 1; -# Allow for long double string conversions. -$y->{num}->[3] += 0; -$r->{num}->[3] += 0; -ok 4, nfreeze($y) eq nfreeze($r); - -ok 5, $y->ref->{key1} eq 'val1'; -ok 6, $y->ref->{key2} eq 'val2'; -ok 7, $hash_fetch == 2; - -my $num = $r->num; -my $ok = 1; -for (my $i = 0; $i < @$num; $i++) { - do { $ok = 0; last } unless $num->[$i] == $y->num->[$i]; -} -ok 8, $ok; - -__END__ -# -# using Storable-0.6@11, output of: print pack("u", nfreeze(ROOT->make)); -# original size: 278 bytes -# -M`P,````%!`(````&"(%8"(!8"'U8"@@M,RXQ-#$U.5@)```!R%@*`S0N-5A8 -M6`````-N=6T$`P````(*!'9A;#%8````!&ME>3$*!'9A;#)8````!&ME>3)B -M"51)141?2$%32%A8`````6@$`@````,*!G-T<FEN9U@$``````I8!``````` -M6%A8`````6$$`@````4$`@````$(@%AB!E-)35!,15A8!`(````!"(%88@93 -M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8 -M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E -(9F($4D]/5%@` -# -# using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make)); -# on OS/390 (cp 1047) original size: 217 bytes -# -#M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(*!*6!D_$````$DH6H -#M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D) -#M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("```` -#M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00````` -#E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0`` diff --git a/ext/Storable/t/croak.t b/ext/Storable/t/croak.t deleted file mode 100644 index ecd2bf831b..0000000000 --- a/ext/Storable/t/croak.t +++ /dev/null @@ -1,38 +0,0 @@ -#!./perl -w - -# Please keep this test this simple. (ie just one test.) -# There's some sort of not-croaking properly problem in Storable when built -# with 5.005_03. This test shows it up, whereas malice.t does not. -# In particular, don't use Test; as this covers up the problem. - -sub BEGIN { - if ($ENV{PERL_CORE}) { - require Config; import Config; - %Config=%Config if 0; # cease -w - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - } -} - -use strict; - -BEGIN { - die "Oi! No! Don't change this test so that Carp is used before Storable" - if defined &Carp::carp; -} -use Storable qw(freeze thaw); - -print "1..2\n"; - -for my $test (1,2) { - eval {thaw "\xFF\xFF"}; - if ($@ =~ /Storable binary image v127.255 more recent than I am \(v2\.\d+\)/) - { - print "ok $test\n"; - } else { - chomp $@; - print "not ok $test # Expected a meaningful croak. Got '$@'\n"; - } -} diff --git a/ext/Storable/t/dclone.t b/ext/Storable/t/dclone.t deleted file mode 100644 index 078cd81f82..0000000000 --- a/ext/Storable/t/dclone.t +++ /dev/null @@ -1,106 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - - -use Storable qw(dclone); - -print "1..12\n"; - -$a = 'toto'; -$b = \$a; -$c = bless {}, CLASS; -$c->{attribute} = 'attrval'; -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); -@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, - $b, \$a, $a, $c, \$c, \%a); - -print "not " unless defined ($aref = dclone(\@a)); -print "ok 1\n"; - -$dumped = &dump(\@a); -print "ok 2\n"; - -$got = &dump($aref); -print "ok 3\n"; - -print "not " unless $got eq $dumped; -print "ok 4\n"; - -package FOO; @ISA = qw(Storable); - -sub make { - my $self = bless {}; - $self->{key} = \%main::a; - return $self; -}; - -package main; - -$foo = FOO->make; -print "not " unless defined($r = $foo->dclone); -print "ok 5\n"; - -print "not " unless &dump($foo) eq &dump($r); -print "ok 6\n"; - -# Ensure refs to "undef" values are properly shared during cloning -my $hash; -push @{$$hash{''}}, \$$hash{a}; -print "not " unless $$hash{''}[0] == \$$hash{a}; -print "ok 7\n"; - -my $cloned = dclone(dclone($hash)); -print "not " unless $$cloned{''}[0] == \$$cloned{a}; -print "ok 8\n"; - -$$cloned{a} = "blah"; -print "not " unless $$cloned{''}[0] == \$$cloned{a}; -print "ok 9\n"; - -# [ID 20020221.007] SEGV in Storable with empty string scalar object -package TestString; -sub new { - my ($type, $string) = @_; - return bless(\$string, $type); -} -package main; -my $empty_string_obj = TestString->new(''); -my $clone = dclone($empty_string_obj); -# If still here after the dclone the fix (#17543) worked. -print ref $clone eq ref $empty_string_obj && - $$clone eq $$empty_string_obj && - $$clone eq '' ? "ok 10\n" : "not ok 10\n"; - - -# Do not fail if Tie::Hash and/or Tie::StdHash is not available -if (eval { require Tie::Hash; scalar keys %Tie::StdHash:: }) { - tie my %tie, "Tie::StdHash" or die $!; - $tie{array} = [1,2,3,4]; - $tie{hash} = {1,2,3,4}; - my $clone_array = dclone $tie{array}; - print "not " unless "@$clone_array" eq "@{$tie{array}}"; - print "ok 11\n"; - my $clone_hash = dclone $tie{hash}; - print "not " unless $clone_hash->{1} eq $tie{hash}{1}; - print "ok 12\n"; -} else { - print <<EOF; -ok 11 # skip No Tie::StdHash available -ok 12 # skip No Tie::StdHash available -EOF -} diff --git a/ext/Storable/t/downgrade.t b/ext/Storable/t/downgrade.t deleted file mode 100644 index 76bd05ae2a..0000000000 --- a/ext/Storable/t/downgrade.t +++ /dev/null @@ -1,506 +0,0 @@ -#!./perl -w -# -# Copyright 2002, Larry Wall. -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -# I ought to keep this test easily backwards compatible to 5.004, so no -# qr//; - -# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features -# are encountered. - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use Test::More; -use Storable 'thaw'; - -use strict; -use vars qw(@RESTRICT_TESTS %R_HASH %U_HASH $UTF8_CROAK $RESTRICTED_CROAK); - -@RESTRICT_TESTS = ('Locked hash', 'Locked hash placeholder', - 'Locked keys', 'Locked keys placeholder', - ); -%R_HASH = (perl => 'rules'); - -if ($] > 5.007002) { - # This is cheating. "\xdf" in Latin 1 is beta S, so will match \w if it - # is stored in utf8, not bytes. - # "\xdf" is y diaresis in EBCDIC (except for cp875, but so far no-one seems - # to use that) which has exactly the same properties for \w - # So the tests happen to pass. - my $utf8 = "Schlo\xdf" . chr 256; - chop $utf8; - - # \xe5 is V in EBCDIC. That doesn't have the same properties w.r.t. \w as - # an a circumflex, so we need to be explicit. - - # and its these very properties we're trying to test - an edge case - # involving whether scalars are being stored in bytes or in utf8. - my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5"); - %U_HASH = (map {$_, $_} 'castle', "ch${a_circumflex}teau", $utf8, chr 0x57CE); - plan tests => 169; -} elsif ($] >= 5.006) { - plan tests => 59; -} else { - plan tests => 67; -} - -$UTF8_CROAK = "/^Cannot retrieve UTF8 data in non-UTF8 perl/"; -$RESTRICTED_CROAK = "/^Cannot retrieve restricted hash/"; - -my %tests; -{ - local $/ = "\n\nend\n"; - while (<DATA>) { - next unless /\S/s; - unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) { - s/\n.*//s; - warn "Dodgy data in section starting '$_'"; - next; - } - next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa - my $data = unpack 'u', $3; - $tests{$2} = $data; - } -} - -# use Data::Dumper; $Data::Dumper::Useqq = 1; print Dumper \%tests; -sub thaw_hash { - my ($name, $expected) = @_; - my $hash = eval {thaw $tests{$name}}; - is ($@, '', "Thawed $name without error?"); - isa_ok ($hash, 'HASH'); - ok (defined $hash && eq_hash($hash, $expected), - "And it is the hash we expected?"); - $hash; -} - -sub thaw_scalar { - my ($name, $expected, $bug) = @_; - my $scalar = eval {thaw $tests{$name}}; - is ($@, '', "Thawed $name without error?"); - isa_ok ($scalar, 'SCALAR', "Thawed $name?"); - if ($bug and $] == 5.006) { - # Aargh. <expletive> <expletive> 5.6.0's harness doesn't even honour - # TODO tests. - warn "# Test skipped because eq is buggy for certain Unicode cases in 5.6.0"; - warn "# Please upgrade to 5.6.1\n"; - ok ("I'd really like to fail this test on 5.6.0 but I'm told that CPAN auto-dependancies mess up, and certain vendors only ship 5.6.0. Get your vendor to ugrade. Else upgrade your vendor."); - # One such vendor being the folks who brought you LONG_MIN as a positive - # integer. - } else { - is ($$scalar, $expected, "And it is the data we expected?"); - } - $scalar; -} - -sub thaw_fail { - my ($name, $expected) = @_; - my $thing = eval {thaw $tests{$name}}; - is ($thing, undef, "Thawed $name failed as expected?"); - like ($@, $expected, "Error as predicted?"); -} - -sub test_locked_hash { - my $hash = shift; - my @keys = keys %$hash; - my ($key, $value) = each %$hash; - eval {$hash->{$key} = reverse $value}; - like( $@, "/^Modification of a read-only value attempted/", - 'trying to change a locked key' ); - is ($hash->{$key}, $value, "hash should not change?"); - eval {$hash->{use} = 'perl'}; - like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/", - 'trying to add another key' ); - ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); -} - -sub test_restricted_hash { - my $hash = shift; - my @keys = keys %$hash; - my ($key, $value) = each %$hash; - eval {$hash->{$key} = reverse $value}; - is( $@, '', - 'trying to change a restricted key' ); - is ($hash->{$key}, reverse ($value), "hash should change"); - eval {$hash->{use} = 'perl'}; - like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/", - 'trying to add another key' ); - ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); -} - -sub test_placeholder { - my $hash = shift; - eval {$hash->{rules} = 42}; - is ($@, '', 'No errors'); - is ($hash->{rules}, 42, "New value added"); -} - -sub test_newkey { - my $hash = shift; - eval {$hash->{nms} = "http://nms-cgi.sourceforge.net/"}; - is ($@, '', 'No errors'); - is ($hash->{nms}, "http://nms-cgi.sourceforge.net/", "New value added"); -} - -# $Storable::DEBUGME = 1; -thaw_hash ('Hash with utf8 flag but no utf8 keys', \%R_HASH); - -if (eval "use Hash::Util; 1") { - print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n"; - for $Storable::downgrade_restricted (0, 1, undef, "cheese") { - my $hash = thaw_hash ('Locked hash', \%R_HASH); - test_locked_hash ($hash); - $hash = thaw_hash ('Locked hash placeholder', \%R_HASH); - test_locked_hash ($hash); - test_placeholder ($hash); - - $hash = thaw_hash ('Locked keys', \%R_HASH); - test_restricted_hash ($hash); - $hash = thaw_hash ('Locked keys placeholder', \%R_HASH); - test_restricted_hash ($hash); - test_placeholder ($hash); - } -} else { - print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n"; - my $hash = thaw_hash ('Locked hash', \%R_HASH); - test_newkey ($hash); - $hash = thaw_hash ('Locked hash placeholder', \%R_HASH); - test_newkey ($hash); - $hash = thaw_hash ('Locked keys', \%R_HASH); - test_newkey ($hash); - $hash = thaw_hash ('Locked keys placeholder', \%R_HASH); - test_newkey ($hash); - local $Storable::downgrade_restricted = 0; - thaw_fail ('Locked hash', $RESTRICTED_CROAK); - thaw_fail ('Locked hash placeholder', $RESTRICTED_CROAK); - thaw_fail ('Locked keys', $RESTRICTED_CROAK); - thaw_fail ('Locked keys placeholder', $RESTRICTED_CROAK); -} - -if ($] >= 5.006) { - print "# We have utf8 scalars, so test that the utf8 scalars in <DATA> are valid\n"; - thaw_scalar ('Short 8 bit utf8 data', "\xDF", 1); - thaw_scalar ('Long 8 bit utf8 data', "\xDF" x 256, 1); - thaw_scalar ('Short 24 bit utf8 data', chr 0xC0FFEE); - thaw_scalar ('Long 24 bit utf8 data', chr (0xC0FFEE) x 256); -} else { - print "# We don't have utf8 scalars, so test that the utf8 scalars downgrade\n"; - thaw_fail ('Short 8 bit utf8 data', $UTF8_CROAK); - thaw_fail ('Long 8 bit utf8 data', $UTF8_CROAK); - thaw_fail ('Short 24 bit utf8 data', $UTF8_CROAK); - thaw_fail ('Long 24 bit utf8 data', $UTF8_CROAK); - local $Storable::drop_utf8 = 1; - my $bytes = thaw $tests{'Short 8 bit utf8 data as bytes'}; - thaw_scalar ('Short 8 bit utf8 data', $$bytes); - thaw_scalar ('Long 8 bit utf8 data', $$bytes x 256); - $bytes = thaw $tests{'Short 24 bit utf8 data as bytes'}; - thaw_scalar ('Short 24 bit utf8 data', $$bytes); - thaw_scalar ('Long 24 bit utf8 data', $$bytes x 256); -} - -if ($] > 5.007002) { - print "# We have utf8 hashes, so test that the utf8 hashes in <DATA> are valid\n"; - my $hash = thaw_hash ('Hash with utf8 keys', \%U_HASH); - my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5"); - for (keys %$hash) { - my $l = 0 + /^\w+$/; - my $r = 0 + $hash->{$_} =~ /^\w+$/; - cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); - cmp_ok ($l, '==', $_ eq "ch${a_circumflex}teau" ? 0 : 1); - } - if (eval "use Hash::Util; 1") { - print "# We have Hash::Util, so test that the restricted utf8 hash is valid\n"; - my $hash = thaw_hash ('Locked hash with utf8 keys', \%U_HASH); - for (keys %$hash) { - my $l = 0 + /^\w+$/; - my $r = 0 + $hash->{$_} =~ /^\w+$/; - cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); - cmp_ok ($l, '==', $_ eq "ch${a_circumflex}teau" ? 0 : 1); - } - test_locked_hash ($hash); - } else { - print "# We don't have Hash::Util, so test that the utf8 hash downgrades\n"; - fail ("You can't get here [perl version $]]. This is a bug in the test. -# Please send the output of perl -V to perlbug\@perl.org"); - } -} else { - print "# We don't have utf8 hashes, so test that the utf8 hashes downgrade\n"; - thaw_fail ('Hash with utf8 keys', $UTF8_CROAK); - thaw_fail ('Locked hash with utf8 keys', $UTF8_CROAK); - local $Storable::drop_utf8 = 1; - my $what = $] < 5.006 ? 'pre 5.6' : '5.6'; - my $expect = thaw $tests{"Hash with utf8 keys for $what"}; - thaw_hash ('Hash with utf8 keys', $expect); - #foreach (keys %$expect) { print "'$_':\t'$expect->{$_}'\n"; } - #foreach (keys %$got) { print "'$_':\t'$got->{$_}'\n"; } - if (eval "use Hash::Util; 1") { - print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n"; - fail ("You can't get here [perl version $]]. This is a bug in the test. -# Please send the output of perl -V to perlbug\@perl.org"); - } else { - print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n"; - my $hash = thaw_hash ('Locked hash with utf8 keys', $expect); - test_newkey ($hash); - local $Storable::downgrade_restricted = 0; - thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK); - # Which croak comes first is a bit of an implementation issue :-) - local $Storable::drop_utf8 = 0; - thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK); - } -} -__END__ -# A whole run of 2.x nfreeze data, uuencoded. The "mode bits" are the octal -# value of 'A', the "file name" is the test name. Use make_downgrade.pl to -# generate these. -begin 101 Locked hash -8!049`0````$*!7)U;&5S!`````1P97)L - -end - -begin 101 Locked hash placeholder -C!049`0````(*!7)U;&5S!`````1P97)L#A0````%<G5L97,` - -end - -begin 101 Locked keys -8!049`0````$*!7)U;&5S``````1P97)L - -end - -begin 101 Locked keys placeholder -C!049`0````(*!7)U;&5S``````1P97)L#A0````%<G5L97,` - -end - -begin 101 Short 8 bit utf8 data -&!047`L.? - -end - -begin 101 Short 8 bit utf8 data as bytes -&!04*`L.? - -end - -begin 101 Long 8 bit utf8 data -M!048```"`,.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? -MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# -MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? -MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# -MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? -MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# -MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? -MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# -MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? -MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# -MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? -8PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? - -end - -begin 101 Short 24 bit utf8 data -)!047!?BPC[^N - -end - -begin 101 Short 24 bit utf8 data as bytes -)!04*!?BPC[^N - -end - -begin 101 Long 24 bit utf8 data -M!048```%`/BPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ -;OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N - -end - -begin 101 Hash with utf8 flag but no utf8 keys -8!049``````$*!7)U;&5S``````1P97)L - -end - -begin 101 Hash with utf8 keys -M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T -D96%U%P/EGXX!`````^6?CA<'4V-H;&_#GP(````&4V-H;&_? - -end - -begin 101 Locked hash with utf8 keys -M!049`0````0*!F-A<W1L900````&8V%S=&QE"@=C:.5T96%U!`````=C:.5T -D96%U%P/EGXX%`````^6?CA<'4V-H;&_#GP8````&4V-H;&_? - -end - -begin 101 Hash with utf8 keys for pre 5.6 -M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T -D96%U"@/EGXX``````^6?C@H'4V-H;&_#GP(````&4V-H;&_? - -end - -begin 101 Hash with utf8 keys for 5.6 -M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T -D96%U%P/EGXX``````^6?CA<'4V-H;&_#GP(````&4V-H;&_? - -end - -begin 301 Locked hash -8!049`0````$*!9FDDX6B!`````27A9F3 - -end - -begin 301 Locked hash placeholder -C!049`0````(.%`````69I).%H@H%F:23A:($````!)>%F9,` - -end - -begin 301 Locked keys -8!049`0````$*!9FDDX6B``````27A9F3 - -end - -begin 301 Locked keys placeholder -C!049`0````(.%`````69I).%H@H%F:23A:(`````!)>%F9,` - -end - -begin 301 Short 8 bit utf8 data -&!047`HMS - -end - -begin 301 Short 8 bit utf8 data as bytes -&!04*`HMS - -end - -begin 301 Long 8 bit utf8 data -M!048```"`(MSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS -MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ -M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS -MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ -M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS -MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ -M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS -MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ -M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS -MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ -M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS -8BW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS - -end - -begin 301 Short 24 bit utf8 data -*!047!OM30G-S50`` - -end - -begin 301 Short 24 bit utf8 data as bytes -*!04*!OM30G-S50`` - -end - -begin 301 Long 24 bit utf8 data -M!048```&`/M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 -M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S --5?M30G-S5?M30G-S50`` - -end - -begin 301 Hash with utf8 flag but no utf8 keys -8!049``````$*!9FDDX6B``````27A9F3 - -end - -begin 301 Hash with utf8 keys -M!049``````0*!X.(1Z.%@:0`````!X.(1Z.%@:0*!H.!HJ.3A0`````&@X&B -FHY.%%P3<9')5`0````3<9')5%P?B@XB3EHMS`@````;B@XB3EM\` - -end - -begin 301 Locked hash with utf8 keys -M!049`0````0*!X.(1Z.%@:0$````!X.(1Z.%@:0*!H.!HJ.3A00````&@X&B -FHY.%%P3<9')5!0````3<9')5%P?B@XB3EHMS!@````;B@XB3EM\` - -end - -begin 301 Hash with utf8 keys for pre 5.6 -M!049``````0*!H.!HJ.3A0`````&@X&BHY.%"@B#B(M&HX6!I``````'@XA' -GHX6!I`H'XH.(DY:+<P(````&XH.(DY;?"@3<9')5``````3<9')5 - -end - -begin 301 Hash with utf8 keys for 5.6 -M!049``````0*!H.!HJ.3A0`````&@X&BHY.%"@>#B$>CA8&D``````>#B$>C -FA8&D%P?B@XB3EHMS`@````;B@XB3EM\7!-QD<E4`````!-QD<E4` - -end diff --git a/ext/Storable/t/file_magic.t b/ext/Storable/t/file_magic.t deleted file mode 100644 index f834510287..0000000000 --- a/ext/Storable/t/file_magic.t +++ /dev/null @@ -1,455 +0,0 @@ -#!perl -w - -use strict; -use Test::More; -use Storable qw(store nstore); -use Config qw(%Config); - -# The @tests array below was create by the following program -my $dummy = <<'EOT'; -use Storable; -use Data::Dump qw(dump); - -print "my \@tests = (\n"; -for my $f (<data_*>) { - print " [\n"; - print " " . dump(substr(`cat $f`, 0, 32) . "...") , ",\n"; - - my $x = dump(Storable::file_magic($f)); - $x =~ s/^/ /gm; - print "$x,\n"; - - print " ],\n"; -} -print ");\n"; -EOT - -my @tests = ( - [ - "perl-store\x041234\4\4\4\xD4\xC2\32\b\3\13\0\0\0v\b\xC5\32\b...", - { - byteorder => 1234, - file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.1.le32", - hdrsize => 18, - intsize => 4, - longsize => 4, - netorder => 0, - ptrsize => 4, - version => -1, - version_nv => -1, - }, - ], - [ - "perl-store\0\x041234\4\4\4\x8Co\34\b\3\13\0\0\0v\x94v\34...", - { - byteorder => 1234, - file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.4_07.le32", - hdrsize => 19, - intsize => 4, - longsize => 4, - major => 0, - netorder => 0, - ptrsize => 4, - version => 0, - version_nv => 0, - }, - ], - [ - "perl-store\1\x8Co\34\b\3\0\0\0\13v\x94v\34\b\1\0\0\4\0\0\0...", - { - file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.4_07.neutral", - hdrsize => 11, - major => 0, - netorder => 1, - version => 0, - version_nv => 0, - }, - ], - [ - "pst0\2\x041234\4\4\4\3\13\0\0\0\1\0\4\0\0\0\0\0\0\0\0\0\0\0...", - { - byteorder => 1234, - file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.604.le32", - hdrsize => 13, - intsize => 4, - longsize => 4, - major => 1, - netorder => 0, - ptrsize => 4, - version => 1, - version_nv => 1, - }, - ], - [ - "pst0\3\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0...", - { - file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.604.neutral", - hdrsize => 5, - major => 1, - netorder => 1, - version => 1, - version_nv => 1, - }, - ], - [ - "pst0\4\0\x041234\4\4\4\3\13\0\0\0\1\0\4\0\0\0\0\0\0\0\0\0\0...", - { - byteorder => 1234, - file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.700.le32", - hdrsize => 14, - intsize => 4, - longsize => 4, - major => 2, - minor => 0, - netorder => 0, - ptrsize => 4, - version => "2.0", - version_nv => "2.000", - }, - ], - [ - "pst0\5\0\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0...", - { - file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.700.neutral", - hdrsize => 6, - major => 2, - minor => 0, - netorder => 1, - version => "2.0", - version_nv => "2.000", - }, - ], - [ - "pst0\4\4\x041234\4\4\4\x08\3\13\0\0\0\1\0\4\0\0\0\0\0\0\0\0\0...", - { - byteorder => 1234, - file => "data_perl-5.006001_i686-linux-thread-multi_Storable-1.012.le32", - hdrsize => 15, - intsize => 4, - longsize => 4, - major => 2, - minor => 4, - netorder => 0, - nvsize => 8, - ptrsize => 4, - version => "2.4", - version_nv => "2.004", - }, - ], - [ - "pst0\4\3\x044321\4\4\4\x08\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0...", - { - byteorder => 4321, - file => "data_perl-5.006001_IA64.ARCHREV_0-thread-multi_Storable-1.006.be32", - hdrsize => 15, - intsize => 4, - longsize => 4, - major => 2, - minor => 3, - netorder => 0, - nvsize => 8, - ptrsize => 4, - version => "2.3", - version_nv => "2.003", - }, - ], - [ - "pst0\5\3\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0...", - { - file => "data_perl-5.006001_IA64.ARCHREV_0-thread-multi_Storable-1.006.neutral", - hdrsize => 6, - major => 2, - minor => 3, - netorder => 1, - version => "2.3", - version_nv => "2.003", - }, - ], - [ - "pst0\4\4\x044321\4\4\4\x08\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0...", - { - byteorder => 4321, - file => "data_perl-5.006001_IA64.ARCHREV_0-thread-multi_Storable-1.012.be32", - hdrsize => 15, - intsize => 4, - longsize => 4, - major => 2, - minor => 4, - netorder => 0, - nvsize => 8, - ptrsize => 4, - version => "2.4", - version_nv => "2.004", - }, - ], - [ - "pst0\5\4\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0...", - { - file => "data_perl-5.006001_IA64.ARCHREV_0-thread-multi_Storable-1.012.neutral", - hdrsize => 6, - major => 2, - minor => 4, - netorder => 1, - version => "2.4", - version_nv => "2.004", - }, - ], - [ - "pst0\4\6\x044321\4\4\4\x08\3\0\0\0\13\n\n4294967296...", - { - byteorder => 4321, - file => "data_perl-5.008001_darwin-thread-multi-2level_Storable-2.08.be32", - hdrsize => 15, - intsize => 4, - longsize => 4, - major => 2, - minor => 6, - netorder => 0, - nvsize => 8, - ptrsize => 4, - version => "2.6", - version_nv => "2.006", - }, - ], - [ - "pst0\5\6\3\0\0\0\13\n\n4294967296\0\0\0\bfour_...", - { - file => "data_perl-5.008001_darwin-thread-multi-2level_Storable-2.08.neutral", - hdrsize => 6, - major => 2, - minor => 6, - netorder => 1, - version => "2.6", - version_nv => "2.006", - }, - ], - [ - "pst0\4\6\x044321\4\4\4\x08\3\0\0\0\13\4\3\0\0\0\0\0\0\0\nem...", - { - byteorder => 4321, - file => "data_perl-5.008003_PA-RISC1.1-thread-multi_Storable-2.09.be32", - hdrsize => 15, - intsize => 4, - longsize => 4, - major => 2, - minor => 6, - netorder => 0, - nvsize => 8, - ptrsize => 4, - version => "2.6", - version_nv => "2.006", - }, - ], - [ - "pst0\5\6\3\0\0\0\13\4\3\0\0\0\0\0\0\0\nempty_hash\n...", - { - file => "data_perl-5.008003_PA-RISC1.1-thread-multi_Storable-2.09.neutral", - hdrsize => 6, - major => 2, - minor => 6, - netorder => 1, - version => "2.6", - version_nv => "2.006", - }, - ], - [ - "pst0\4\6\x0812345678\4\4\4\x08\3\13\0\0\0\4\3\0\0\0\0\n\0...", - { - byteorder => 12_345_678, - file => "data_perl-5.008004_i86pc-solaris-64int_Storable-2.12.le64", - hdrsize => 19, - intsize => 4, - longsize => 4, - major => 2, - minor => 6, - netorder => 0, - nvsize => 8, - ptrsize => 4, - version => "2.6", - version_nv => "2.006", - }, - ], - [ - "pst0\4\6\x041234\4\4\4\x08\3\13\0\0\0\4\3\0\0\0\0\n\0\0\0em...", - { - byteorder => 1234, - file => "data_perl-5.008006_i686-linux-thread-multi_Storable-2.13.le32", - hdrsize => 15, - intsize => 4, - longsize => 4, - major => 2, - minor => 6, - netorder => 0, - nvsize => 8, - ptrsize => 4, - version => "2.6", - version_nv => "2.006", - }, - ], - [ - "pst0\4\6\x0887654321\4\x08\x08\x08\3\0\0\0\13\4\3\0\0\0\0\0\0...", - { - byteorder => 87_654_321, - file => "data_perl-5.008007_IA64.ARCHREV_0-thread-multi-LP64_Storable-2.13.be64", - hdrsize => 19, - intsize => 4, - longsize => 8, - major => 2, - minor => 6, - netorder => 0, - nvsize => 8, - ptrsize => 8, - version => "2.6", - version_nv => "2.006", - }, - ], - [ - "pst0\4\x07\x0812345678\4\x08\x08\x08\3\13\0\0\0\4\3\0\0\0\0\n\0...", - { - byteorder => 12_345_678, - file => "data_perl-5.008007_x86-solaris-thread-multi-64_Storable-2.15.le64", - hdrsize => 19, - intsize => 4, - longsize => 8, - major => 2, - minor => 7, - netorder => 0, - nvsize => 8, - ptrsize => 8, - version => "2.7", - version_nv => "2.007", - }, - ], - [ - "pst0\5\x07\3\0\0\0\13\4\3\0\0\0\0\0\0\0\nempty_hash\n...", - { - file => "data_perl-5.008007_x86-solaris-thread-multi-64_Storable-2.15.neutral", - hdrsize => 6, - major => 2, - minor => 7, - netorder => 1, - version => "2.7", - version_nv => "2.007", - }, - ], - [ - "pst0\4\5\x041234\4\4\4\x08\3\13\0\0\0\4\3\0\0\0\0\n\0\0\0em...", - { - byteorder => 1234, - file => "data_perl-5.008_i686-linux-thread-multi_Storable-2.04.le32", - hdrsize => 15, - intsize => 4, - longsize => 4, - major => 2, - minor => 5, - netorder => 0, - nvsize => 8, - ptrsize => 4, - version => "2.5", - version_nv => "2.005", - }, - ], - [ - "pst0\5\5\3\0\0\0\13\4\3\0\0\0\0\0\0\0\nempty_hash\n...", - { - file => "data_perl-5.008_i686-linux-thread-multi_Storable-2.04.neutral", - hdrsize => 6, - major => 2, - minor => 5, - netorder => 1, - version => "2.5", - version_nv => "2.005", - }, - ], - [ - "pst0\4\x07\x041234\4\4\4\x08\3\13\0\0\0\4\3\0\0\0\0\n\0\0\0em...", - { - byteorder => 1234, - file => "data_perl-5.009003_i686-linux_Storable-2.15.le32", - hdrsize => 15, - intsize => 4, - longsize => 4, - major => 2, - minor => 7, - netorder => 0, - nvsize => 8, - ptrsize => 4, - version => "2.7", - version_nv => "2.007", - }, - ], -); - -plan tests => 31 + 2 * @tests; - -my $file = "xx-$$.pst"; - -is(eval { Storable::file_magic($file) }, undef, "empty file give undef"); -like($@, qq{/^Can't open '\Q$file\E':/}, "...and croaks"); -is(Storable::file_magic(__FILE__), undef, "not an image"); - -store({}, $file); -{ - my $info = Storable::file_magic($file); - unlink($file); - ok($info, "got info"); - is($info->{file}, $file, "file set"); - is($info->{hdrsize}, 11 + length($Config{byteorder}), "hdrsize"); - like($info->{version}, q{/^2\.\d+$/}, "sane version"); - is($info->{version_nv}, Storable::BIN_WRITE_VERSION_NV, "version_nv match"); - is($info->{major}, 2, "sane major"); - ok($info->{minor}, "have minor"); - ok($info->{minor} >= Storable::BIN_WRITE_MINOR, "large enough minor"); - - ok(!$info->{netorder}, "no netorder"); - - my %attrs = ( - nvsize => 5.006, - ptrsize => 5.005, - map {$_ => 5.004} qw(byteorder intsize longsize) - ); - for my $attr (keys %attrs) { - SKIP: { - skip "attribute $attr not available on this version of Perl", 1 if $attrs{$attr} > $]; - is($info->{$attr}, $Config{$attr}, "$attr match Config"); - } - } -} - -nstore({}, $file); -{ - my $info = Storable::file_magic($file); - unlink($file); - ok($info, "got info"); - is($info->{file}, $file, "file set"); - is($info->{hdrsize}, 6, "hdrsize"); - like($info->{version}, q{/^2\.\d+$/}, "sane version"); - is($info->{version_nv}, Storable::BIN_WRITE_VERSION_NV, "version_nv match"); - is($info->{major}, 2, "sane major"); - ok($info->{minor}, "have minor"); - ok($info->{minor} >= Storable::BIN_WRITE_MINOR, "large enough minor"); - - ok($info->{netorder}, "no netorder"); - for (qw(byteorder intsize longsize ptrsize nvsize)) { - ok(!exists $info->{$_}, "no $_"); - } -} - -for my $test (@tests) { - my($data, $expected) = @$test; - open(FH, ">$file") || die "Can't create $file: $!"; - binmode(FH); - print FH $data; - close(FH) || die "Can't write $file: $!"; - - my $name = $expected->{file}; - $expected->{file} = $file; - - my $info = Storable::file_magic($file); - unlink($file); - - is_deeply($info, $expected, "file_magic $name"); - - $expected->{file} = 1; - is_deeply(Storable::read_magic($data), $expected, "read magic $name"); -} diff --git a/ext/Storable/t/forgive.t b/ext/Storable/t/forgive.t deleted file mode 100644 index 495edc339a..0000000000 --- a/ext/Storable/t/forgive.t +++ /dev/null @@ -1,65 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# Original Author: Ulrich Pfeifer -# (C) Copyright 1997, Universitat Dortmund, all rights reserved. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use Storable qw(store retrieve); - -# problems with 5.00404 when in an BEGIN block, so this is defined here -if (!eval { require File::Spec; 1 } || $File::Spec::VERSION < 0.8) { - print "1..0 # Skip: File::Spec 0.8 needed\n"; - exit 0; - # Mention $File::Spec::VERSION again, as 5.00503's harness seems to have - # warnings on. - exit $File::Spec::VERSION; -} - -print "1..8\n"; - -my $test = 1; -*GLOB = *GLOB; # peacify -w -my $bad = ['foo', \*GLOB, 'bar']; -my $result; - -eval {$result = store ($bad , 'store')}; -print ((!defined $result)?"ok $test\n":"not ok $test\n"); $test++; -print (($@ ne '')?"ok $test\n":"not ok $test\n"); $test++; - -$Storable::forgive_me=1; - -my $devnull = File::Spec->devnull; - -open(SAVEERR, ">&STDERR"); -open(STDERR, ">$devnull") or - ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); - -eval {$result = store ($bad , 'store')}; - -open(STDERR, ">&SAVEERR"); - -print ((defined $result)?"ok $test\n":"not ok $test\n"); $test++; -print (($@ eq '')?"ok $test\n":"not ok $test\n"); $test++; - -my $ret = retrieve('store'); -print ((defined $ret)?"ok $test\n":"not ok $test\n"); $test++; -print (($ret->[0] eq 'foo')?"ok $test\n":"not ok $test\n"); $test++; -print (($ret->[2] eq 'bar')?"ok $test\n":"not ok $test\n"); $test++; -print ((ref $ret->[1] eq 'SCALAR')?"ok $test\n":"not ok $test\n"); $test++; - - -END { 1 while unlink 'store' } diff --git a/ext/Storable/t/freeze.t b/ext/Storable/t/freeze.t deleted file mode 100644 index e76b669820..0000000000 --- a/ext/Storable/t/freeze.t +++ /dev/null @@ -1,146 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; - sub ok; -} - -use Storable qw(freeze nfreeze thaw); - -print "1..20\n"; - -$a = 'toto'; -$b = \$a; -$c = bless {}, CLASS; -$c->{attribute} = $b; -$d = {}; -$e = []; -$d->{'a'} = $e; -$e->[0] = $d; -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); -@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $d, \$d, \$e, $e, - $b, \$a, $a, $c, \$c, \%a); - -print "not " unless defined ($f1 = freeze(\@a)); -print "ok 1\n"; - -$dumped = &dump(\@a); -print "ok 2\n"; - -$root = thaw($f1); -print "not " unless defined $root; -print "ok 3\n"; - -$got = &dump($root); -print "ok 4\n"; - -print "not " unless $got eq $dumped; -print "ok 5\n"; - -package FOO; @ISA = qw(Storable); - -sub make { - my $self = bless {}; - $self->{key} = \%main::a; - return $self; -}; - -package main; - -$foo = FOO->make; -print "not " unless $f2 = $foo->freeze; -print "ok 6\n"; - -print "not " unless $f3 = $foo->nfreeze; -print "ok 7\n"; - -$root3 = thaw($f3); -print "not " unless defined $root3; -print "ok 8\n"; - -print "not " unless &dump($foo) eq &dump($root3); -print "ok 9\n"; - -$root = thaw($f2); -print "not " unless &dump($foo) eq &dump($root); -print "ok 10\n"; - -print "not " unless &dump($root3) eq &dump($root); -print "ok 11\n"; - -$other = freeze($root); -print "not " unless length($other) == length($f2); -print "ok 12\n"; - -$root2 = thaw($other); -print "not " unless &dump($root2) eq &dump($root); -print "ok 13\n"; - -$VAR1 = [ - 'method', - 1, - 'prepare', - 'SELECT table_name, table_owner, num_rows FROM iitables - where table_owner != \'$ingres\' and table_owner != \'DBA\'' -]; - -$x = nfreeze($VAR1); -$VAR2 = thaw($x); -print "not " unless $VAR2->[3] eq $VAR1->[3]; -print "ok 14\n"; - -# Test the workaround for LVALUE bug in perl 5.004_04 -- from Gisle Aas -sub foo { $_[0] = 1 } -$foo = []; -foo($foo->[1]); -eval { freeze($foo) }; -print "not " if $@; -print "ok 15\n"; - -# Test cleanup bug found by Claudio Garcia -- RAM, 08/06/2001 -my $thaw_me = 'asdasdasdasd'; - -eval { - my $thawed = thaw $thaw_me; -}; -ok 16, $@; - -my %to_be_frozen = (foo => 'bar'); -my $frozen; -eval { - $frozen = freeze \%to_be_frozen; -}; -ok 17, !$@; - -freeze {}; -eval { thaw $thaw_me }; -eval { $frozen = freeze { foo => {} } }; -ok 18, !$@; - -thaw $frozen; # used to segfault here -ok 19, 1; - -if ($] >= 5.006) { - eval ' - $a = []; $#$a = 2; $a->[1] = undef; - $b = thaw freeze $a; - @a = map { ~~ exists $a->[$_] } 0 .. $#$a; - @b = map { ~~ exists $b->[$_] } 0 .. $#$b; - ok 20, "@a" eq "@b"; - '; -} -else { - print "ok 20 # skipped (no av_exists)\n"; -} diff --git a/ext/Storable/t/integer.t b/ext/Storable/t/integer.t deleted file mode 100644 index 2c22235a83..0000000000 --- a/ext/Storable/t/integer.t +++ /dev/null @@ -1,177 +0,0 @@ -#!./perl -w -# -# Copyright 2002, Larry Wall. -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -# I ought to keep this test easily backwards compatible to 5.004, so no -# qr//; - -# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features -# are encountered. - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use Test::More; -use Storable qw (dclone store retrieve freeze thaw nstore nfreeze); -use strict; - -my $max_uv = ~0; -my $max_uv_m1 = ~0 ^ 1; -# Express it in this way so as not to use any addition, as 5.6 maths would -# do this in NVs on 64 bit machines, and we're overflowing IVs so can't use -# use integer. -my $max_iv_p1 = $max_uv ^ ($max_uv >> 1); -my $lots_of_9C = do { - my $temp = sprintf "%#x", ~0; - $temp =~ s/ff/9c/g; - local $^W; - eval $temp; -}; - -my $max_iv = ~0 >> 1; -my $min_iv = do {use integer; -$max_iv-1}; # 2s complement assumption - -my @processes = (["dclone", \&do_clone], - ["freeze/thaw", \&freeze_and_thaw], - ["nfreeze/thaw", \&nfreeze_and_thaw], - ["store/retrieve", \&store_and_retrieve], - ["nstore/retrieve", \&nstore_and_retrieve], - ); -my @numbers = - (# IV bounds of 8 bits - -1, 0, 1, -127, -128, -129, 42, 126, 127, 128, 129, 254, 255, 256, 257, - # IV bounds of 32 bits - -2147483647, -2147483648, -2147483649, 2147483646, 2147483647, 2147483648, - # IV bounds - $min_iv, do {use integer; $min_iv + 1}, do {use integer; $max_iv - 1}, - $max_iv, - # UV bounds at 32 bits - 0x7FFFFFFF, 0x80000000, 0x80000001, 0xFFFFFFFF, 0xDEADBEEF, - # UV bounds - $max_iv_p1, $max_uv_m1, $max_uv, $lots_of_9C, - # NV-UV conversion - 2559831922.0, - ); - -plan tests => @processes * @numbers * 5; - -my $file = "integer.$$"; -die "Temporary file '$file' already exists" if -e $file; - -END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} - -sub do_clone { - my $data = shift; - my $copy = eval {dclone $data}; - is ($@, '', 'Should be no error dcloning'); - ok (1, "dlcone is only 1 process, not 2"); - return $copy; -} - -sub freeze_and_thaw { - my $data = shift; - my $frozen = eval {freeze $data}; - is ($@, '', 'Should be no error freezing'); - my $copy = eval {thaw $frozen}; - is ($@, '', 'Should be no error thawing'); - return $copy; -} - -sub nfreeze_and_thaw { - my $data = shift; - my $frozen = eval {nfreeze $data}; - is ($@, '', 'Should be no error nfreezing'); - my $copy = eval {thaw $frozen}; - is ($@, '', 'Should be no error thawing'); - return $copy; -} - -sub store_and_retrieve { - my $data = shift; - my $frozen = eval {store $data, $file}; - is ($@, '', 'Should be no error storing'); - my $copy = eval {retrieve $file}; - is ($@, '', 'Should be no error retrieving'); - return $copy; -} - -sub nstore_and_retrieve { - my $data = shift; - my $frozen = eval {nstore $data, $file}; - is ($@, '', 'Should be no error storing'); - my $copy = eval {retrieve $file}; - is ($@, '', 'Should be no error retrieving'); - return $copy; -} - -foreach (@processes) { - my ($process, $sub) = @$_; - foreach my $number (@numbers) { - # as $number is an alias into @numbers, we don't want any side effects of - # conversion macros affecting later runs, so pass a copy to Storable: - my $copy1 = my $copy2 = my $copy0 = $number; - my $copy_s = &$sub (\$copy0); - if (is (ref $copy_s, "SCALAR", "got back a scalar ref?")) { - # Test inside use integer to see if the bit pattern is identical - # and outside to see if the sign is right. - # On 5.8 we don't need this trickery anymore. - # We really do need 2 copies here, as conversion may have side effect - # bugs. In particular, I know that this happens: - # perl5.00503 -le '$a = "-2147483649"; $a & 0; print $a; print $a+1' - # -2147483649 - # 2147483648 - - my $copy_s1 = my $copy_s2 = $$copy_s; - # On 5.8 can do this with a straight ==, due to the integer/float maths - # on 5.6 can't do this with - # my $eq = do {use integer; $copy_s1 == $copy1} && $copy_s1 == $copy1; - # because on builds with IV as long long it tickles bugs. - # (Uncomment it and the Devel::Peek line below to see the messed up - # state of the scalar, with PV showing the correct string for the - # number, and IV holding a bogus value which has been truncated to 32 bits - - # So, check the bit patterns are identical, and check that the sign is the - # same. This works on all the versions in all the sizes. - # $eq = && (($copy_s1 <=> 0) == ($copy1 <=> 0)); - # Split this into 2 tests, to cater for 5.005_03 - - # Aargh. Even this doesn't work because 5.6.x sends values with (same - # number of decimal digits as ~0 + 1) via atof. So ^ is getting strings - # cast to doubles cast to integers. And that truncates low order bits. - # my $bit = ok (($copy_s1 ^ $copy1) == 0, "$process $copy1 (bitpattern)"); - - # Oh well; at least the parser gets it right. :-) - my $copy_s3 = eval $copy_s1; - die "Was supposed to have number $copy_s3, got error $@" - unless defined $copy_s3; - my $bit = ok (($copy_s3 ^ $copy1) == 0, "$process $copy1 (bitpattern)"); - # This is sick. 5.005_03 survives without the IV/UV flag, and somehow - # gets it right, providing you don't have side effects of conversion. -# local $TODO; -# $TODO = "pre 5.6 doesn't have flag to distinguish IV/UV" -# if $[ < 5.005_56 and $copy1 > $max_iv; - my $sign = ok (($copy_s2 <=> 0) == ($copy2 <=> 0), - "$process $copy1 (sign)"); - - unless ($bit and $sign) { - printf "# Passed in %s (%#x, %i)\n# got back '%s' (%#x, %i)\n", - $copy1, $copy1, $copy1, $copy_s1, $copy_s1, $copy_s1; - # use Devel::Peek; Dump $number; Dump $copy1; Dump $copy_s1; - } - # unless ($bit) { use Devel::Peek; Dump $copy_s1; Dump $$copy_s; } - } else { - fail ("$process $copy1"); - fail ("$process $copy1"); - } - } -} diff --git a/ext/Storable/t/interwork56.t b/ext/Storable/t/interwork56.t deleted file mode 100644 index 4e9b414e54..0000000000 --- a/ext/Storable/t/interwork56.t +++ /dev/null @@ -1,195 +0,0 @@ -#!./perl -w -# -# Copyright 2002, Larry Wall. -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -# I ought to keep this test easily backwards compatible to 5.004, so no -# qr//; - -# This test checks whether the kludge to interwork with 5.6 Storables compiled -# on Unix systems with IV as long long works. - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - unless ($Config{ivsize} and $Config{ivsize} > $Config{longsize}) { - print "1..0 # Skip: Your IVs are no larger than your longs\n"; - exit 0; - } -} - -use Storable qw(freeze thaw); -use strict; -use Test::More tests=>30; - -use vars qw(%tests); - -{ - local $/ = "\n\nend\n"; - while (<DATA>) { - next unless /\S/s; - unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) { - s/\n.*//s; - warn "Dodgy data in section starting '$_'"; - next; - } - next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa - my $data = unpack 'u', $3; - $tests{$2} = $data; - } -} - -# perl makes easy things easy, and hard things possible: -my $test = freeze \'Hell'; - -my $header = Storable::read_magic ($test); - -is ($header->{byteorder}, $Config{byteorder}, - "header's byteorder and Config.pm's should agree"); - -my $result = eval {thaw $test}; -isa_ok ($result, 'SCALAR', "Check thawing test data"); -is ($@, '', "causes no errors"); -is ($$result, 'Hell', 'and gives the expected data'); - -my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu"; - -my $name = join ',', $kingdom, @$header{qw(intsize longsize ptrsize nvsize)}; - -SKIP: { - my $real_thing = $tests{$name}; - if (!defined $real_thing) { - print << "EOM"; -# No test data for Storable 1.x for: -# -# byteorder '$Config{byteorder}' -# sizeof(int) $$header{intsize} -# sizeof(long) $$header{longsize} -# sizeof(char *) $$header{ptrsize} -# sizeof(NV) $$header{nvsize} - -# If you have Storable 1.x built with perl 5.6.x on this platform, please -# make_56_interwork.pl to generate test data, and append the test data to -# this test. -# You may find that make_56_interwork.pl reports that your platform has no -# interworking problems, in which case you need do nothing. -EOM - skip "# No 1.x test file", 9; - } - my $result = eval {thaw $real_thing}; - is ($result, undef, "By default should not be able to thaw"); - like ($@, qr/Byte order is not compatible/, - "because the header byte order strings differ"); - local $Storable::interwork_56_64bit = 1; - $result = eval {thaw $real_thing}; - isa_ok ($result, 'ARRAY', "With flag should now thaw"); - is ($@, '', "with no errors"); - - # However, as the file is written with Storable pre 2.01, it's a known - # bug that large (positive) UVs become IVs - my $value = (~0 ^ (~0 >> 1) ^ 2); - - is (@$result, 4, "4 elements in array"); - like ($$result[0], - qr/^This file was written with [0-9.]+ on perl [0-9.]+\z/, - "1st element"); - is ($$result[1], "$kingdom was correct", "2nd element"); - cmp_ok ($$result[2] ^ $value, '==', 0, "3rd element") or - printf "# expected %#X, got %#X\n", $value, $$result[2]; - is ($$result[3], "The End", "4th element"); -} - -$result = eval {thaw $test}; -isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data"); -is ($@, '', " causes no errors"); -is ($$result, 'Hell', " and gives the expected data"); - -my $test_kludge; -{ - local $Storable::interwork_56_64bit = 1; - $test_kludge = freeze \'Heck'; -} - -my $header_kludge = Storable::read_magic ($test_kludge); - -cmp_ok (length ($header_kludge->{byteorder}), '==', $Config{longsize}, - "With 5.6 interwork kludge byteorder string should be same size as long" - ); -$result = eval {thaw $test_kludge}; -is ($result, undef, "By default should not be able to thaw"); -like ($@, qr/Byte order is not compatible/, - "because the header byte order strings differ"); - -$result = eval {thaw $test}; -isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data"); -is ($@, '', " causes no errors"); -is ($$result, 'Hell', " and gives the expected data"); - -{ - local $Storable::interwork_56_64bit = 1; - - $result = eval {thaw $test_kludge}; - isa_ok ($result, 'SCALAR', "should be able to thaw kludge data"); - is ($@, '', "with no errors"); - is ($$result, 'Heck', "and gives expected data"); - - $result = eval {thaw $test}; - is ($result, undef, "But now can't thaw real data"); - like ($@, qr/Byte order is not compatible/, - "because the header byte order strings differ"); -} - -# All together now: -$result = eval {thaw $test}; -isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data"); -is ($@, '', " causes no errors"); -is ($$result, 'Hell', " and gives the expected data"); - -__END__ -# A whole run of 1.1.14 freeze data, uuencoded. The "mode bits" are the octal -# value of 'A', the "file name" is the test name. Use make_56_interwork.pl -# with a copy of Storable 1.X generate these. - -# byteorder '1234' -# sizeof(int) 4 -# sizeof(long) 4 -# sizeof(char *) 4 -# sizeof(NV) 8 -begin 101 Lillput,4,4,4,8 -M!`0$,3(S-`0$!`@"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@ -M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8" -0````````@`H'5&AE($5N9``` - -end - -# byteorder '4321' -# sizeof(int) 4 -# sizeof(long) 4 -# sizeof(char *) 4 -# sizeof(NV) 8 -begin 101 Belfuscu,4,4,4,8 -M!`0$-#,R,00$!`@"````!`HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@ -M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H40F5L9G5S8W4@=V%S(&-O<G)E8W0& -1@`````````(*!U1H92!%;F0` - -end - -# byteorder '1234' -# sizeof(int) 4 -# sizeof(long) 4 -# sizeof(char *) 4 -# sizeof(NV) 12 -begin 101 Lillput,4,4,4,12 -M!`0$,3(S-`0$!`P"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@ -M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8" -0````````@`H'5&AE($5N9``` - -end - diff --git a/ext/Storable/t/just_plain_nasty.t b/ext/Storable/t/just_plain_nasty.t deleted file mode 100644 index 85eaa901cf..0000000000 --- a/ext/Storable/t/just_plain_nasty.t +++ /dev/null @@ -1,146 +0,0 @@ -#!/usr/bin/perl - -# This is a test suite to cover all the nasty and horrible data -# structures that cause bizarre corner cases. - -# Everyone's invited! :-D - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use strict; -BEGIN { - if (!eval q{ - use Test; - use B::Deparse 0.61; - use 5.006; - 1; - }) { - print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n"; - exit; - } - require File::Spec; - if ($File::Spec::VERSION < 0.8) { - print "1..0 # Skip: newer File::Spec needed\n"; - exit 0; - } -} - -use Storable qw(freeze thaw); - -#$Storable::DEBUGME = 1; -BEGIN { - plan tests => 34; -} - -{ - package Banana; - use overload - '<=>' => \&compare, - '==' => \&equal, - '""' => \&real, - fallback => 1; - sub compare { return int(rand(3))-1 }; - sub equal { return 1 if rand(1) > 0.5 } - sub real { return "keep it so" } -} - -my (@a); - -for my $dbun (1, 0) { # dbun - don't be utterly nasty - being utterly - # nasty means having a reference to the object - # directly within itself. otherwise it's in the - # second array. - my $nasty = [ - ($a[0] = bless [ ], "Banana"), - ($a[1] = [ ]), - ]; - - $a[$dbun]->[0] = $a[0]; - - ok(ref($nasty), "ARRAY", "Sanity found (now to play with it :->)"); - - $Storable::Deparse = $Storable::Deparse = 1; - $Storable::Eval = $Storable::Eval = 1; - - headit("circular overload 1 - freeze"); - my $icicle = freeze $nasty; - #print $icicle; # cat -ve recommended :) - headit("circular overload 1 - thaw"); - my $oh_dear = thaw $icicle; - ok(ref($oh_dear), "ARRAY", "dclone - circular overload"); - ok($oh_dear->[0], "keep it so", "amagic ok 1"); - ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2"); - - headit("closure dclone - freeze"); - $icicle = freeze sub { "two" }; - #print $icicle; - headit("closure dclone - thaw"); - my $sub2 = thaw $icicle; - ok($sub2->(), "two", "closures getting dcloned OK"); - - headit("circular overload, after closure - freeze"); - #use Data::Dumper; - #print Dumper $nasty; - $icicle = freeze $nasty; - #print $icicle; - headit("circular overload, after closure - thaw"); - $oh_dear = thaw $icicle; - ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone"); - ok($oh_dear->[0], "keep it so", "amagic ok 1"); - ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2"); - - push @{$nasty}, sub { print "Goodbye, cruel world.\n" }; - headit("closure freeze AFTER circular overload"); - #print Dumper $nasty; - $icicle = freeze $nasty; - #print $icicle; - headit("circular thaw AFTER circular overload"); - $oh_dear = thaw $icicle; - ok(ref($oh_dear), "ARRAY", "dclone - before a closure dclone"); - ok($oh_dear->[0], "keep it so", "amagic ok 1"); - ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2"); - - @{$nasty} = @{$nasty}[0, 2, 1]; - headit("closure freeze BETWEEN circular overload"); - #print Dumper $nasty; - $icicle = freeze $nasty; - #print $icicle; - headit("circular thaw BETWEEN circular overload"); - $oh_dear = thaw $icicle; - ok(ref($oh_dear), "ARRAY", "dclone - between a closure dclone"); - ok($oh_dear->[0], "keep it so", "amagic ok 1"); - ok($oh_dear->[$dbun?2:0]->[0], "keep it so", "amagic ok 2"); - - @{$nasty} = @{$nasty}[1, 0, 2]; - headit("closure freeze BEFORE circular overload"); - #print Dumper $nasty; - $icicle = freeze $nasty; - #print $icicle; - headit("circular thaw BEFORE circular overload"); - $oh_dear = thaw $icicle; - ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone"); - ok($oh_dear->[1], "keep it so", "amagic ok 1"); - ok($oh_dear->[$dbun+1]->[0], "keep it so", "amagic ok 2"); -} - -sub headit { - - return; # comment out to get headings - useful for scanning - # output with $Storable::DEBUGME = 1 - - my $title = shift; - - my $size_left = (66 - length($title)) >> 1; - my $size_right = (67 - length($title)) >> 1; - - print "# ".("-" x $size_left). " $title " - .("-" x $size_right)."\n"; -} - diff --git a/ext/Storable/t/lock.t b/ext/Storable/t/lock.t deleted file mode 100644 index 14b5f4261a..0000000000 --- a/ext/Storable/t/lock.t +++ /dev/null @@ -1,46 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - - require 'st-dump.pl'; -} - -sub ok; - -use Storable qw(lock_store lock_retrieve); - -unless (&Storable::CAN_FLOCK) { - print "1..0 # Skip: fcntl/flock emulation broken on this platform\n"; - exit 0; -} - -print "1..5\n"; - -@a = ('first', undef, 3, -4, -3.14159, 456, 4.5); - -# -# We're just ensuring things work, we're not validating locking. -# - -ok 1, defined lock_store(\@a, 'store'); -ok 2, $dumped = &dump(\@a); - -$root = lock_retrieve('store'); -ok 3, ref $root eq 'ARRAY'; -ok 4, @a == @$root; -ok 5, &dump($root) eq $dumped; - -unlink 't/store'; - diff --git a/ext/Storable/t/make_56_interwork.pl b/ext/Storable/t/make_56_interwork.pl deleted file mode 100644 index c73e9b6d90..0000000000 --- a/ext/Storable/t/make_56_interwork.pl +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/bin/perl -w -use strict; - -use Config; -use Storable qw(freeze thaw); - -# Lilliput decreed that eggs should be eaten small end first. -# Belfuscu welcomed the rebels who wanted to eat big end first. -my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu"; - -my $frozen = freeze - ["This file was written with $Storable::VERSION on perl $]", - "$kingdom was correct", (~0 ^ (~0 >> 1) ^ 2), - "The End"]; - -my $ivsize = $Config{ivsize} || $Config{longsize}; - -my $storesize = unpack 'xxC', $frozen; -my $storebyteorder = unpack "xxxA$storesize", $frozen; - -if ($Config{byteorder} eq $storebyteorder) { - my $ivtype = $Config{ivtype} || 'long'; - print <<"EOM"; -You only need to run this generator program where Config.pm's byteorder string -is not the same length as the size of IVs. - -This length difference should only happen on perl 5.6.x configured with IVs as -long long on Unix, OS/2 or any platform that runs the Configure stript (ie not -MS Windows) - -This is perl $], sizeof(long) is $Config{longsize}, IVs are '$ivtype', sizeof(IV) is $ivsize, -byteorder is '$Config{byteorder}', Storable $Storable::VERSION writes a byteorder of '$storebyteorder' -EOM - exit; # Grr ' -} - -my ($i, $l, $p, $n) = unpack "xxxx${storesize}CCCC", $frozen; - -print <<"EOM"; -# byteorder '$storebyteorder' -# sizeof(int) $i -# sizeof(long) $l -# sizeof(char *) $p -# sizeof(NV) $n -EOM - -my $uu = pack 'u', $frozen; - -printf "begin %3o $kingdom,$i,$l,$p,$n\n", ord 'A'; -print $uu; -print "\nend\n\n"; diff --git a/ext/Storable/t/make_downgrade.pl b/ext/Storable/t/make_downgrade.pl deleted file mode 100644 index fc801a4953..0000000000 --- a/ext/Storable/t/make_downgrade.pl +++ /dev/null @@ -1,106 +0,0 @@ -#!/usr/local/bin/perl -w -use strict; - -use 5.007003; -use Hash::Util qw(lock_hash unlock_hash lock_keys); -use Storable qw(nfreeze); - -# If this looks like a hack, it's probably because it is :-) -sub uuencode_it { - my ($data, $name) = @_; - my $frozen = nfreeze $data; - - my $uu = pack 'u', $frozen; - - printf "begin %3o $name\n", ord 'A'; - print $uu; - print "\nend\n\n"; -} - - -my %hash = (perl=>"rules"); - -lock_hash %hash; - -uuencode_it (\%hash, "Locked hash"); - -unlock_hash %hash; - -lock_keys %hash, 'perl', 'rules'; -lock_hash %hash; - -uuencode_it (\%hash, "Locked hash placeholder"); - -unlock_hash %hash; - -lock_keys %hash, 'perl'; - -uuencode_it (\%hash, "Locked keys"); - -unlock_hash %hash; - -lock_keys %hash, 'perl', 'rules'; - -uuencode_it (\%hash, "Locked keys placeholder"); - -unlock_hash %hash; - -my $utf8 = "\x{DF}\x{100}"; -chop $utf8; - -uuencode_it (\$utf8, "Short 8 bit utf8 data"); - -my $utf8b = $utf8; -utf8::encode ($utf8b); - -uuencode_it (\$utf8b, "Short 8 bit utf8 data as bytes"); - -$utf8 x= 256; - -uuencode_it (\$utf8, "Long 8 bit utf8 data"); - -$utf8 = "\x{C0FFEE}"; - -uuencode_it (\$utf8, "Short 24 bit utf8 data"); - -$utf8b = $utf8; -utf8::encode ($utf8b); - -uuencode_it (\$utf8b, "Short 24 bit utf8 data as bytes"); - -$utf8 x= 256; - -uuencode_it (\$utf8, "Long 24 bit utf8 data"); - -# Hash which has the utf8 bit set, but no longer has any utf8 keys -my %uhash = ("\x{100}", "gone", "perl", "rules"); -delete $uhash{"\x{100}"}; - -# use Devel::Peek; Dump \%uhash; -uuencode_it (\%uhash, "Hash with utf8 flag but no utf8 keys"); - -$utf8 = "Schlo\xdf" . chr 256; -chop $utf8; -my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5"); -%uhash = (map {$_, $_} 'castle', "ch${a_circumflex}teau", $utf8, "\x{57CE}"); - -uuencode_it (\%uhash, "Hash with utf8 keys"); - -lock_hash %uhash; - -uuencode_it (\%uhash, "Locked hash with utf8 keys"); - -my (%pre56, %pre58); - -while (my ($key, $val) = each %uhash) { - # hash keys are always stored downgraded to bytes if possible, with a flag - # to say "promote back to utf8" - # Whereas scalars are stored as is. - utf8::encode ($key) if ord $key > 256; - $pre58{$key} = $val; - utf8::encode ($val) unless $val eq "ch\xe5teau"; - $pre56{$key} = $val; - -} -uuencode_it (\%pre56, "Hash with utf8 keys for pre 5.6"); -uuencode_it (\%pre58, "Hash with utf8 keys for 5.6"); diff --git a/ext/Storable/t/make_overload.pl b/ext/Storable/t/make_overload.pl deleted file mode 100644 index bd224f5373..0000000000 --- a/ext/Storable/t/make_overload.pl +++ /dev/null @@ -1,13 +0,0 @@ -#!/usr/local/bin/perl -w -use strict; - -use Storable qw(nfreeze); -use HAS_OVERLOAD; - -my $o = HAS_OVERLOAD->make("snow"); -my $f = nfreeze \$o; - -my $uu = pack 'u', $f; - -print $uu; - diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t deleted file mode 100644 index ddb65ddf2c..0000000000 --- a/ext/Storable/t/malice.t +++ /dev/null @@ -1,309 +0,0 @@ -#!./perl -w -# -# Copyright 2002, Larry Wall. -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -# I'm trying to keep this test easily backwards compatible to 5.004, so no -# qr//; - -# This test tries to craft malicious data to test out as many different -# error traps in Storable as possible -# It also acts as a test for read_header - -sub BEGIN { - # This lets us distribute Test::More in t/ - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use strict; -use vars qw($file_magic_str $other_magic $network_magic $byteorder - $major $minor $minor_write $fancy); - -$byteorder = $Config{byteorder}; - -$file_magic_str = 'pst0'; -$other_magic = 7 + length $byteorder; -$network_magic = 2; -$major = 2; -$minor = 7; -$minor_write = $] > 5.005_50 ? 7 : 4; - -use Test::More; - -# If it's 5.7.3 or later the hash will be stored with flags, which is -# 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header -# common to normal and network order serialised objects (hence the 8) -# There are only 2 * 2 tests per byte in the parts of the header not present -# for network order, and 2 tests per byte on the 'pst0' "magic number" only -# present in files, but not in things store()ed to memory -$fancy = ($] > 5.007 ? 2 : 0); - -plan tests => 372 + length ($byteorder) * 4 + $fancy * 8; - -use Storable qw (store retrieve freeze thaw nstore nfreeze); -require 'testlib.pl'; -use vars '$file'; - -# The chr 256 is a hack to force the hash to always have the utf8 keys flag -# set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because -# only there does the hash has the flag on, and hence only there is it stored -# as a flagged hash, which is 2 bytes longer -my %hash = (perl => 'rules', chr 256, ''); -delete $hash{chr 256}; - -sub test_hash { - my $clone = shift; - is (ref $clone, "HASH", "Get hash back"); - is (scalar keys %$clone, 1, "with 1 key"); - is ((keys %$clone)[0], "perl", "which is correct"); - is ($clone->{perl}, "rules"); -} - -sub test_header { - my ($header, $isfile, $isnetorder) = @_; - is (!!$header->{file}, !!$isfile, "is file"); - is ($header->{major}, $major, "major number"); - is ($header->{minor}, $minor_write, "minor number"); - is (!!$header->{netorder}, !!$isnetorder, "is network order"); - if ($isnetorder) { - # Network order header has no sizes - } else { - is ($header->{byteorder}, $byteorder, "byte order"); - is ($header->{intsize}, $Config{intsize}, "int size"); - is ($header->{longsize}, $Config{longsize}, "long size"); - SKIP: { - skip ("No \$Config{prtsize} on this perl version ($])", 1) - unless defined $Config{ptrsize}; - is ($header->{ptrsize}, $Config{ptrsize}, "long size"); - } - is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8, - "nv size"); # 5.00405 doesn't even have doublesize in config. - } -} - -sub test_truncated { - my ($data, $sub, $magic_len, $what) = @_; - for my $i (0 .. length ($data) - 1) { - my $short = substr $data, 0, $i; - - # local $Storable::DEBUGME = 1; - my $clone = &$sub($short); - is (defined ($clone), '', "truncated $what to $i should fail"); - if ($i < $magic_len) { - like ($@, "/^Magic number checking on storable $what failed/", - "Should croak with magic number warning"); - } else { - is ($@, "", "Should not set \$\@"); - } - } -} - -sub test_corrupt { - my ($data, $sub, $what, $name) = @_; - - my $clone = &$sub($data); - is (defined ($clone), '', "$name $what should fail"); - like ($@, $what, $name); -} - -sub test_things { - my ($contents, $sub, $what, $isnetwork) = @_; - my $isfile = $what eq 'file'; - my $file_magic = $isfile ? length $file_magic_str : 0; - - my $header = Storable::read_magic ($contents); - test_header ($header, $isfile, $isnetwork); - - # Test that if we re-write it, everything still works: - my $clone = &$sub ($contents); - - is ($@, "", "There should be no error"); - - test_hash ($clone); - - # Now lets check the short version: - test_truncated ($contents, $sub, $file_magic - + ($isnetwork ? $network_magic : $other_magic), $what); - - my $copy; - if ($isfile) { - $copy = $contents; - substr ($copy, 0, 4) = 'iron'; - test_corrupt ($copy, $sub, "/^File is not a perl storable/", - "magic number"); - } - - $copy = $contents; - # Needs to be more than 1, as we're already coding a spread of 1 minor version - # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3 - # on 5.005_03 (No utf8). - # 4 allows for a small safety margin - # (Joke: - # Question: What is the value of pi? - # Mathematician answers "It's pi, isn't it" - # Physicist answers "3.1, within experimental error" - # Engineer answers "Well, allowing for a small safety margin, 18" - # ) - my $minor4 = $header->{minor} + 4; - substr ($copy, $file_magic + 1, 1) = chr $minor4; - { - # Now by default newer minor version numbers are not a pain. - $clone = &$sub($copy); - is ($@, "", "by default no error on higher minor"); - test_hash ($clone); - - local $Storable::accept_future_minor = 0; - test_corrupt ($copy, $sub, - "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/", - "higher minor"); - } - - $copy = $contents; - my $major1 = $header->{major} + 1; - substr ($copy, $file_magic, 1) = chr 2*$major1; - test_corrupt ($copy, $sub, - "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/", - "higher major"); - - # Continue messing with the previous copy - my $minor1 = $header->{minor} - 1; - substr ($copy, $file_magic + 1, 1) = chr $minor1; - test_corrupt ($copy, $sub, - "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/", - "higher major, lower minor"); - - my $where; - if (!$isnetwork) { - # All these are omitted from the network order header. - # I'm not sure if it's correct to omit the byte size stuff. - $copy = $contents; - substr ($copy, $file_magic + 3, length $header->{byteorder}) - = reverse $header->{byteorder}; - - test_corrupt ($copy, $sub, "/^Byte order is not compatible/", - "byte order"); - $where = $file_magic + 3 + length $header->{byteorder}; - foreach (['intsize', "Integer"], - ['longsize', "Long integer"], - ['ptrsize', "Pointer"], - ['nvsize', "Double"]) { - my ($key, $name) = @$_; - $copy = $contents; - substr ($copy, $where++, 1) = chr 0; - test_corrupt ($copy, $sub, "/^$name size is not compatible/", - "$name size"); - } - } else { - $where = $file_magic + $network_magic; - } - - # Just the header and a tag 255. As 28 is currently the highest tag, this - # is "unexpected" - $copy = substr ($contents, 0, $where) . chr 255; - - test_corrupt ($copy, $sub, - "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/", - "bogus tag"); - - # Now drop the minor version number - substr ($copy, $file_magic + 1, 1) = chr $minor1; - - test_corrupt ($copy, $sub, - "/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/", - "bogus tag, minor less 1"); - # Now increase the minor version number - substr ($copy, $file_magic + 1, 1) = chr $minor4; - - # local $Storable::DEBUGME = 1; - # This is the delayed croak - test_corrupt ($copy, $sub, - "/^Storable binary image v$header->{major}.$minor4 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 28/", - "bogus tag, minor plus 4"); - # And check again that this croak is not delayed: - { - # local $Storable::DEBUGME = 1; - local $Storable::accept_future_minor = 0; - test_corrupt ($copy, $sub, - "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/", - "higher minor"); - } -} - -ok (defined store(\%hash, $file)); - -my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy; -my $length = -s $file; - -die "Don't seem to have written file '$file' as I can't get its length: $!" - unless defined $file; - -die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length" - unless $length == $expected; - -# Read the contents into memory: -my $contents = slurp ($file); - -# Test the original direct from disk -my $clone = retrieve $file; -test_hash ($clone); - -# Then test it. -test_things($contents, \&store_and_retrieve, 'file'); - -# And now try almost everything again with a Storable string -my $stored = freeze \%hash; -test_things($stored, \&freeze_and_thaw, 'string'); - -# Network order. -unlink $file or die "Can't unlink '$file': $!"; - -ok (defined nstore(\%hash, $file)); - -$expected = 20 + length ($file_magic_str) + $network_magic + $fancy; -$length = -s $file; - -die "Don't seem to have written file '$file' as I can't get its length: $!" - unless defined $file; - -die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length" - unless $length == $expected; - -# Read the contents into memory: -$contents = slurp ($file); - -# Test the original direct from disk -$clone = retrieve $file; -test_hash ($clone); - -# Then test it. -test_things($contents, \&store_and_retrieve, 'file', 1); - -# And now try almost everything again with a Storable string -$stored = nfreeze \%hash; -test_things($stored, \&freeze_and_thaw, 'string', 1); - -# Test that the bug fixed by #20587 doesn't affect us under some older -# Perl. AMS 20030901 -{ - chop(my $a = chr(0xDF).chr(256)); - my %a = (chr(0xDF) => 1); - $a{$a}++; - freeze \%a; - # If we were built with -DDEBUGGING, the assert() should have killed - # us, which will probably alert the user that something went wrong. - ok(1); -} - -# Unusual in that the empty string is stored with an SX_LSCALAR marker -my $hash = store_and_retrieve("pst0\5\6\3\0\0\0\1\1\0\0\0\0\0\0\0\5empty"); -ok(!$@, "no exception"); -is(ref($hash), "HASH", "got a hash"); -is($hash->{empty}, "", "got empty element"); diff --git a/ext/Storable/t/overload.t b/ext/Storable/t/overload.t deleted file mode 100644 index 22fccfb61b..0000000000 --- a/ext/Storable/t/overload.t +++ /dev/null @@ -1,114 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw); - -print "1..19\n"; - -package OVERLOADED; - -use overload - '""' => sub { $_[0][0] }; - -package main; - -$a = bless [77], OVERLOADED; - -$b = thaw freeze $a; -ok 1, ref $b eq 'OVERLOADED'; -ok 2, "$b" eq "77"; - -$c = thaw freeze \$a; -ok 3, ref $c eq 'REF'; -ok 4, ref $$c eq 'OVERLOADED'; -ok 5, "$$c" eq "77"; - -$d = thaw freeze [$a, $a]; -ok 6, "$d->[0]" eq "77"; -$d->[0][0]++; -ok 7, "$d->[1]" eq "78"; - -package REF_TO_OVER; - -sub make { - my $self = bless {}, shift; - my ($over) = @_; - $self->{over} = $over; - return $self; -} - -package OVER; - -use overload - '+' => \&plus, - '""' => sub { ref $_[0] }; - -sub plus { - return 314; -} - -sub make { - my $self = bless {}, shift; - my $ref = REF_TO_OVER->make($self); - $self->{ref} = $ref; - return $self; -} - -package main; - -$a = OVER->make(); -$b = thaw freeze $a; - -ok 8, ref $b eq 'OVER'; -ok 9, $a + $a == 314; -ok 10, ref $b->{ref} eq 'REF_TO_OVER'; -ok 11, "$b->{ref}->{over}" eq "$b"; -ok 12, $b + $b == 314; - -# nfreeze data generated by make_overload.pl -my $f = ''; -if (ord ('A') == 193) { # EBCDIC. - $f = unpack 'u', q{7!084$0S(P>)MUN7%V=/6P<0*!**5EJ8`}; -}else { - $f = unpack 'u', q{7!084$0Q(05-?3U9%4DQ/040*!'-N;W<`}; -} - -# see note at the end of do_retrieve in Storable.xs about why this test has to -# use a reference to an overloaded reference, rather than just a reference. -my $t = eval {thaw $f}; -print "# $@" if $@; -ok 13, $@ eq ""; -ok 14, ref ($t) eq 'REF'; -ok 15, ref ($$t) eq 'HAS_OVERLOAD'; -ok 16, $$$t eq 'snow'; - - -#--- -# blessed reference to overloded object. -{ - my $a = bless [88], 'OVERLOADED'; - my $c = thaw freeze bless \$a, 'main'; - ok 17, ref $c eq 'main'; - ok 18, ref $$c eq 'OVERLOADED'; - ok 19, "$$c" eq "88"; - -} - -1; diff --git a/ext/Storable/t/recurse.t b/ext/Storable/t/recurse.t deleted file mode 100644 index d7dcb0e010..0000000000 --- a/ext/Storable/t/recurse.t +++ /dev/null @@ -1,315 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw dclone); - -print "1..33\n"; - -package OBJ_REAL; - -use Storable qw(freeze thaw); - -@x = ('a', 1); - -sub make { bless [], shift } - -sub STORABLE_freeze { - my $self = shift; - my $cloning = shift; - die "STORABLE_freeze" unless Storable::is_storing; - return (freeze(\@x), $self); -} - -sub STORABLE_thaw { - my $self = shift; - my $cloning = shift; - my ($x, $obj) = @_; - die "STORABLE_thaw #1" unless $obj eq $self; - my $len = length $x; - my $a = thaw $x; - die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; - die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1; - @$self = @$a; - die "STORABLE_thaw #4" unless Storable::is_retrieving; -} - -package OBJ_SYNC; - -@x = ('a', 1); - -sub make { bless {}, shift } - -sub STORABLE_freeze { - my $self = shift; - my ($cloning) = @_; - return if $cloning; - return ("", \@x, $self); -} - -sub STORABLE_thaw { - my $self = shift; - my ($cloning, $undef, $a, $obj) = @_; - die "STORABLE_thaw #1" unless $obj eq $self; - die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2; - $self->{ok} = $self; -} - -package OBJ_SYNC2; - -use Storable qw(dclone); - -sub make { - my $self = bless {}, shift; - my ($ext) = @_; - $self->{sync} = OBJ_SYNC->make; - $self->{ext} = $ext; - return $self; -} - -sub STORABLE_freeze { - my $self = shift; - my %copy = %$self; - my $r = \%copy; - my $t = dclone($r->{sync}); - return ("", [$t, $self->{ext}], $r, $self, $r->{ext}); -} - -sub STORABLE_thaw { - my $self = shift; - my ($cloning, $undef, $a, $r, $obj, $ext) = @_; - die "STORABLE_thaw #1" unless $obj eq $self; - die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; - die "STORABLE_thaw #3" unless ref $r eq 'HASH'; - die "STORABLE_thaw #4" unless $a->[1] == $r->{ext}; - $self->{ok} = $self; - ($self->{sync}, $self->{ext}) = @$a; -} - -package OBJ_REAL2; - -use Storable qw(freeze thaw); - -$MAX = 20; -$recursed = 0; -$hook_called = 0; - -sub make { bless [], shift } - -sub STORABLE_freeze { - my $self = shift; - $hook_called++; - return (freeze($self), $self) if ++$recursed < $MAX; - return ("no", $self); -} - -sub STORABLE_thaw { - my $self = shift; - my $cloning = shift; - my ($x, $obj) = @_; - die "STORABLE_thaw #1" unless $obj eq $self; - $self->[0] = thaw($x) if $x ne "no"; - $recursed--; -} - -package main; - -my $real = OBJ_REAL->make; -my $x = freeze $real; -ok 1, 1; - -my $y = thaw $x; -ok 2, ref $y eq 'OBJ_REAL'; -ok 3, $y->[0] eq 'a'; -ok 4, $y->[1] == 1; - -my $sync = OBJ_SYNC->make; -$x = freeze $sync; -ok 5, 1; - -$y = thaw $x; -ok 6, 1; -ok 7, $y->{ok} == $y; - -my $ext = [1, 2]; -$sync = OBJ_SYNC2->make($ext); -$x = freeze [$sync, $ext]; -ok 8, 1; - -my $z = thaw $x; -$y = $z->[0]; -ok 9, 1; -ok 10, $y->{ok} == $y; -ok 11, ref $y->{sync} eq 'OBJ_SYNC'; -ok 12, $y->{ext} == $z->[1]; - -$real = OBJ_REAL2->make; -$x = freeze $real; -ok 13, 1; -ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX; -ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX; - -$y = thaw $x; -ok 16, 1; -ok 17, $OBJ_REAL2::recursed == 0; - -$x = dclone $real; -ok 18, 1; -ok 19, ref $x eq 'OBJ_REAL2'; -ok 20, $OBJ_REAL2::recursed == 0; -ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX; - -ok 22, !Storable::is_storing; -ok 23, !Storable::is_retrieving; - -# -# The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx> -# sent me, along with a proposed fix. -# - -package Foo; - -sub new { - my $class = shift; - my $dat = shift; - return bless {dat => $dat}, $class; -} - -package Bar; -sub new { - my $class = shift; - return bless { - a => 'dummy', - b => [ - Foo->new(1), - Foo->new(2), # Second instance of a Foo - ] - }, $class; -} - -sub STORABLE_freeze { - my($self,$clonning) = @_; - return "$self->{a}", $self->{b}; -} - -sub STORABLE_thaw { - my($self,$clonning,$dummy,$o) = @_; - $self->{a} = $dummy; - $self->{b} = $o; -} - -package main; - -my $bar = new Bar; -my $bar2 = thaw freeze $bar; - -ok 24, ref($bar2) eq 'Bar'; -ok 25, ref($bar->{b}[0]) eq 'Foo'; -ok 26, ref($bar->{b}[1]) eq 'Foo'; -ok 27, ref($bar2->{b}[0]) eq 'Foo'; -ok 28, ref($bar2->{b}[1]) eq 'Foo'; - -# -# The following attempts to make sure blessed objects are blessed ASAP -# at retrieve time. -# - -package CLASS_1; - -sub make { - my $self = bless {}, shift; - return $self; -} - -package CLASS_2; - -sub make { - my $self = bless {}, shift; - my ($o) = @_; - $self->{c1} = CLASS_1->make(); - $self->{o} = $o; - $self->{c3} = bless CLASS_1->make(), "CLASS_3"; - $o->set_c2($self); - return $self; -} - -sub STORABLE_freeze { - my($self, $clonning) = @_; - return "", $self->{c1}, $self->{c3}, $self->{o}; -} - -sub STORABLE_thaw { - my($self, $clonning, $frozen, $c1, $c3, $o) = @_; - main::ok 29, ref $self eq "CLASS_2"; - main::ok 30, ref $c1 eq "CLASS_1"; - main::ok 31, ref $c3 eq "CLASS_3"; - main::ok 32, ref $o eq "CLASS_OTHER"; - $self->{c1} = $c1; - $self->{c3} = $c3; -} - -package CLASS_OTHER; - -sub make { - my $self = bless {}, shift; - return $self; -} - -sub set_c2 { $_[0]->{c2} = $_[1] } - -# -# Is the reference count of the extra references returned from a -# STORABLE_freeze hook correct? [ID 20020601.005] -# -package Foo2; - -sub new { - my $self = bless {}, $_[0]; - $self->{freezed} = "$self"; - return $self; -} - -sub DESTROY { - my $self = shift; - $::refcount_ok = 1 unless "$self" eq $self->{freezed}; -} - -package Foo3; - -sub new { - bless {}, $_[0]; -} - -sub STORABLE_freeze { - my $obj = shift; - return ("", $obj, Foo2->new); -} - -sub STORABLE_thaw { } # Not really used - -package main; -use vars qw($refcount_ok); - -my $o = CLASS_OTHER->make(); -my $c2 = CLASS_2->make($o); -my $so = thaw freeze $o; - -$refcount_ok = 0; -thaw freeze(Foo3->new); -ok 33, $refcount_ok == 1; diff --git a/ext/Storable/t/restrict.t b/ext/Storable/t/restrict.t deleted file mode 100644 index be7f4087f6..0000000000 --- a/ext/Storable/t/restrict.t +++ /dev/null @@ -1,129 +0,0 @@ -#!./perl -w -# -# Copyright 2002, Larry Wall. -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - if ($ENV{PERL_CORE}){ - require Config; - if ($Config::Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - } else { - if ($] < 5.005) { - print "1..0 # Skip: No Hash::Util pre 5.005\n"; - exit 0; - # And doing this seems on 5.004 seems to create bogus warnings about - # unitialized variables, or coredumps in Perl_pp_padsv - } elsif (!eval "require Hash::Util") { - if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/s) { - print "1..0 # Skip: No Hash::Util:\n"; - exit 0; - } else { - die; - } - } - unshift @INC, 't'; - } - require 'st-dump.pl'; -} - - -use Storable qw(dclone freeze thaw); -use Hash::Util qw(lock_hash unlock_value); - -print "1..100\n"; - -my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef); -lock_hash %hash; -unlock_value %hash, 'answer'; -unlock_value %hash, 'extra'; -delete $hash{'extra'}; - -my $test; - -package Restrict_Test; - -sub me_second { - return (undef, $_[0]); -} - -package main; - -sub freeze_thaw { - my $temp = freeze $_[0]; - return thaw $temp; -} - -sub testit { - my $hash = shift; - my $cloner = shift; - my $copy = &$cloner($hash); - - my @in_keys = sort keys %$hash; - my @out_keys = sort keys %$copy; - unless (ok ++$test, "@in_keys" eq "@out_keys") { - print "# Failed: keys mis-match after deep clone.\n"; - print "# Original keys: @in_keys\n"; - print "# Copy's keys: @out_keys\n"; - } - - # $copy = $hash; # used in initial debug of the tests - - ok ++$test, Internals::SvREADONLY(%$copy), "cloned hash restricted?"; - - ok ++$test, Internals::SvREADONLY($copy->{question}), - "key 'question' not locked in copy?"; - - ok ++$test, !Internals::SvREADONLY($copy->{answer}), - "key 'answer' not locked in copy?"; - - eval { $copy->{extra} = 15 } ; - unless (ok ++$test, !$@, "Can assign to reserved key 'extra'?") { - my $diag = $@; - $diag =~ s/\n.*\z//s; - print "# \$\@: $diag\n"; - } - - eval { $copy->{nono} = 7 } ; - ok ++$test, $@, "Can not assign to invalid key 'nono'?"; - - ok ++$test, exists $copy->{undef}, - "key 'undef' exists"; - - ok ++$test, !defined $copy->{undef}, - "value for key 'undef' is undefined"; -} - -for $Storable::canonical (0, 1) { - for my $cloner (\&dclone, \&freeze_thaw) { - print "# \$Storable::canonical = $Storable::canonical\n"; - testit (\%hash, $cloner); - my $object = \%hash; - # bless {}, "Restrict_Test"; - - my %hash2; - $hash2{"k$_"} = "v$_" for 0..16; - lock_hash %hash2; - for (0..16) { - unlock_value %hash2, "k$_"; - delete $hash2{"k$_"}; - } - my $copy = &$cloner(\%hash2); - - for (0..16) { - my $k = "k$_"; - eval { $copy->{$k} = undef } ; - unless (ok ++$test, !$@, "Can assign to reserved key '$k'?") { - my $diag = $@; - $diag =~ s/\n.*\z//s; - print "# \$\@: $diag\n"; - } - } - } -} diff --git a/ext/Storable/t/retrieve.t b/ext/Storable/t/retrieve.t deleted file mode 100644 index 2e44d5d7cb..0000000000 --- a/ext/Storable/t/retrieve.t +++ /dev/null @@ -1,69 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - - -use Storable qw(store retrieve nstore); - -print "1..14\n"; - -$a = 'toto'; -$b = \$a; -$c = bless {}, CLASS; -$c->{attribute} = 'attrval'; -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); -@a = ('first', '', undef, 3, -4, -3.14159, 456, 4.5, - $b, \$a, $a, $c, \$c, \%a); - -print "not " unless defined store(\@a, 'store'); -print "ok 1\n"; -print "not " if Storable::last_op_in_netorder(); -print "ok 2\n"; -print "not " unless defined nstore(\@a, 'nstore'); -print "ok 3\n"; -print "not " unless Storable::last_op_in_netorder(); -print "ok 4\n"; -print "not " unless Storable::last_op_in_netorder(); -print "ok 5\n"; - -$root = retrieve('store'); -print "not " unless defined $root; -print "ok 6\n"; -print "not " if Storable::last_op_in_netorder(); -print "ok 7\n"; - -$nroot = retrieve('nstore'); -print "not " unless defined $nroot; -print "ok 8\n"; -print "not " unless Storable::last_op_in_netorder(); -print "ok 9\n"; - -$d1 = &dump($root); -print "ok 10\n"; -$d2 = &dump($nroot); -print "ok 11\n"; - -print "not " unless $d1 eq $d2; -print "ok 12\n"; - -# Make sure empty string is defined at retrieval time -print "not " unless defined $root->[1]; -print "ok 13\n"; -print "not " if length $root->[1]; -print "ok 14\n"; - -END { 1 while unlink('store', 'nstore') } diff --git a/ext/Storable/t/sig_die.t b/ext/Storable/t/sig_die.t deleted file mode 100644 index d2390a7621..0000000000 --- a/ext/Storable/t/sig_die.t +++ /dev/null @@ -1,39 +0,0 @@ -#!./perl -# -# Copyright (c) 2002 Slaven Rezic -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use strict; -BEGIN { - if (!eval q{ - use Test::More; - 1; - }) { - print "1..0 # skip: tests only work with Test::More\n"; - exit; - } -} - -BEGIN { plan tests => 1 } - -my @warns; -$SIG{__WARN__} = sub { push @warns, shift }; -$SIG{__DIE__} = sub { require Carp; warn Carp::longmess(); warn "Evil die!" }; - -require Storable; - -Storable::dclone({foo => "bar"}); - -is(join("", @warns), "", "__DIE__ is not evil here"); diff --git a/ext/Storable/t/st-dump.pl b/ext/Storable/t/st-dump.pl deleted file mode 100644 index 152b85a101..0000000000 --- a/ext/Storable/t/st-dump.pl +++ /dev/null @@ -1,165 +0,0 @@ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -# NOTE THAT THIS FILE IS COPIED FROM ext/Storable/t/st-dump.pl -# TO t/lib/st-dump.pl. One could also play games with -# File::Spec->updir and catdir to get the st-dump.pl in -# ext/Storable into @INC. - -sub ok { - my ($num, $ok, $name) = @_; - $num .= " - $name" if defined $name and length $name; - print $ok ? "ok $num\n" : "not ok $num\n"; - $ok; -} - -sub num_equal { - my ($num, $left, $right, $name) = @_; - my $ok = ((defined $left) ? $left == $right : undef); - unless (ok ($num, $ok, $name)) { - print "# Expected $right\n"; - if (!defined $left) { - print "# Got undef\n"; - } elsif ($left !~ tr/0-9//c) { - print "# Got $left\n"; - } else { - $left =~ s/([^-a-zA-Z0-9_+])/sprintf "\\%03o", ord $1/ge; - print "# Got \"$left\"\n"; - } - } - $ok; -} - -package dump; -use Carp; - -%dump = ( - 'SCALAR' => 'dump_scalar', - 'LVALUE' => 'dump_scalar', - 'ARRAY' => 'dump_array', - 'HASH' => 'dump_hash', - 'REF' => 'dump_ref', -); - -# Given an object, dump its transitive data closure -sub main'dump { - my ($object) = @_; - croak "Not a reference!" unless ref($object); - local %dumped; - local %object; - local $count = 0; - local $dumped = ''; - &recursive_dump($object, 1); - return $dumped; -} - -# This is the root recursive dumping routine that may indirectly be -# called by one of the routine it calls... -# The link parameter is set to false when the reference passed to -# the routine is an internal temporay variable, implying the object's -# address is not to be dumped in the %dumped table since it's not a -# user-visible object. -sub recursive_dump { - my ($object, $link) = @_; - - # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...). - # Then extract the bless, ref and address parts of that string. - - my $what = "$object"; # Stringify - my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/; - ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless; - - # Special case for references to references. When stringified, - # they appear as being scalars. However, ref() correctly pinpoints - # them as being references indirections. And that's it. - - $ref = 'REF' if ref($object) eq 'REF'; - - # Make sure the object has not been already dumped before. - # We don't want to duplicate data. Retrieval will know how to - # relink from the previously seen object. - - if ($link && $dumped{$addr}++) { - my $num = $object{$addr}; - $dumped .= "OBJECT #$num seen\n"; - return; - } - - my $objcount = $count++; - $object{$addr} = $objcount; - - # Call the appropriate dumping routine based on the reference type. - # If the referenced was blessed, we bless it once the object is dumped. - # The retrieval code will perform the same on the last object retrieved. - - croak "Unknown simple type '$ref'" unless defined $dump{$ref}; - - &{$dump{$ref}}($object); # Dump object - &bless($bless) if $bless; # Mark it as blessed, if necessary - - $dumped .= "OBJECT $objcount\n"; -} - -# Indicate that current object is blessed -sub bless { - my ($class) = @_; - $dumped .= "BLESS $class\n"; -} - -# Dump single scalar -sub dump_scalar { - my ($sref) = @_; - my $scalar = $$sref; - unless (defined $scalar) { - $dumped .= "UNDEF\n"; - return; - } - my $len = length($scalar); - $dumped .= "SCALAR len=$len $scalar\n"; -} - -# Dump array -sub dump_array { - my ($aref) = @_; - my $items = 0 + @{$aref}; - $dumped .= "ARRAY items=$items\n"; - foreach $item (@{$aref}) { - unless (defined $item) { - $dumped .= 'ITEM_UNDEF' . "\n"; - next; - } - $dumped .= 'ITEM '; - &recursive_dump(\$item, 1); - } -} - -# Dump hash table -sub dump_hash { - my ($href) = @_; - my $items = scalar(keys %{$href}); - $dumped .= "HASH items=$items\n"; - foreach $key (sort keys %{$href}) { - $dumped .= 'KEY '; - &recursive_dump(\$key, undef); - unless (defined $href->{$key}) { - $dumped .= 'VALUE_UNDEF' . "\n"; - next; - } - $dumped .= 'VALUE '; - &recursive_dump(\$href->{$key}, 1); - } -} - -# Dump reference to reference -sub dump_ref { - my ($rref) = @_; - my $deref = $$rref; # Follow reference to reference - $dumped .= 'REF '; - &recursive_dump($deref, 1); # $dref is a reference -} - -1; diff --git a/ext/Storable/t/store.t b/ext/Storable/t/store.t deleted file mode 100644 index 61bcf7d49b..0000000000 --- a/ext/Storable/t/store.t +++ /dev/null @@ -1,109 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - -use Storable qw(store retrieve store_fd nstore_fd fd_retrieve); - -print "1..20\n"; - -$a = 'toto'; -$b = \$a; -$c = bless {}, CLASS; -$c->{attribute} = 'attrval'; -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); -@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, - $b, \$a, $a, $c, \$c, \%a); - -print "not " unless defined store(\@a, 'store'); -print "ok 1\n"; - -$dumped = &dump(\@a); -print "ok 2\n"; - -$root = retrieve('store'); -print "not " unless defined $root; -print "ok 3\n"; - -$got = &dump($root); -print "ok 4\n"; - -print "not " unless $got eq $dumped; -print "ok 5\n"; - -1 while unlink 'store'; - -package FOO; @ISA = qw(Storable); - -sub make { - my $self = bless {}; - $self->{key} = \%main::a; - return $self; -}; - -package main; - -$foo = FOO->make; -print "not " unless $foo->store('store'); -print "ok 6\n"; - -print "not " unless open(OUT, '>>store'); -print "ok 7\n"; -binmode OUT; - -print "not " unless defined store_fd(\@a, ::OUT); -print "ok 8\n"; -print "not " unless defined nstore_fd($foo, ::OUT); -print "ok 9\n"; -print "not " unless defined nstore_fd(\%a, ::OUT); -print "ok 10\n"; - -print "not " unless close(OUT); -print "ok 11\n"; - -print "not " unless open(OUT, 'store'); -binmode OUT; - -$r = fd_retrieve(::OUT); -print "not " unless defined $r; -print "ok 12\n"; -print "not " unless &dump($foo) eq &dump($r); -print "ok 13\n"; - -$r = fd_retrieve(::OUT); -print "not " unless defined $r; -print "ok 14\n"; -print "not " unless &dump(\@a) eq &dump($r); -print "ok 15\n"; - -$r = fd_retrieve(main::OUT); -print "not " unless defined $r; -print "ok 16\n"; -print "not " unless &dump($foo) eq &dump($r); -print "ok 17\n"; - -$r = fd_retrieve(::OUT); -print "not " unless defined $r; -print "ok 18\n"; -print "not " unless &dump(\%a) eq &dump($r); -print "ok 19\n"; - -eval { $r = fd_retrieve(::OUT); }; -print "not " unless $@; -print "ok 20\n"; - -close OUT or die "Could not close: $!"; -END { 1 while unlink 'store' } diff --git a/ext/Storable/t/testlib.pl b/ext/Storable/t/testlib.pl deleted file mode 100644 index 6d885d7f68..0000000000 --- a/ext/Storable/t/testlib.pl +++ /dev/null @@ -1,38 +0,0 @@ -#!perl -w -use strict; -use vars '$file'; - -$file = "storable-testfile.$$"; -die "Temporary file '$file' already exists" if -e $file; - -END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} - -use Storable qw (store retrieve freeze thaw nstore nfreeze); - -sub slurp { - my $file = shift; - local (*FH, $/); - open FH, "<$file" or die "Can't open '$file': $!"; - binmode FH; - my $contents = <FH>; - die "Can't read $file: $!" unless defined $contents; - return $contents; -} - -sub store_and_retrieve { - my $data = shift; - unlink $file or die "Can't unlink '$file': $!"; - open FH, ">$file" or die "Can't open '$file': $!"; - binmode FH; - print FH $data or die "Can't print to '$file': $!"; - close FH or die "Can't close '$file': $!"; - - return eval {retrieve $file}; -} - -sub freeze_and_thaw { - my $data = shift; - return eval {thaw $data}; -} - -$file; diff --git a/ext/Storable/t/threads.t b/ext/Storable/t/threads.t deleted file mode 100644 index 72efdda334..0000000000 --- a/ext/Storable/t/threads.t +++ /dev/null @@ -1,57 +0,0 @@ - -# as of 2.09 on win32 Storable w/threads dies with "free to wrong -# pool" since it uses the same context for different threads. since -# win32 perl implementation allocates a different memory pool for each -# thread using the a memory pool from one thread to allocate memory -# for another thread makes win32 perl very unhappy -# -# but the problem exists everywhere, not only on win32 perl , it's -# just hard to catch it deterministically - since the same context is -# used if two or more threads happen to change the state of the -# context in the middle of the operation, and those operations aren't -# atomic per thread, bad things including data loss and corrupted data -# can happen. -# -# this has been solved in 2.10 by adding a Storable::CLONE which calls -# Storable::init_perinterp() to create a new context for each new -# thread when it starts - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - unless ($Config{'useithreads'} and eval { require threads; 1 }) { - print "1..0 # Skip: no threads\n"; - exit 0; - } - # - is \W, so can't use \b at start. Negative look ahead and look behind - # works at start/end of string, or where preceded/followed by spaces - if ($] == 5.008002 and eval q{ $Config{'ccflags'} =~ /(?<!\S)-DDEBUGGING(?!\S)/ }) { - # Bug caused by change 21610, fixed by change 21849 - print "1..0 # Skip: tickles bug in threads combined with -DDEBUGGING on 5.8.2\n"; - exit 0; - } -} - -use Test::More; - -use strict; - -use threads; -use Storable qw(nfreeze); - -plan tests => 2; - -threads->new(\&sub1); - -$_->join() for threads->list(); - -ok 1; - -sub sub1 { - nfreeze {}; - ok 1; -} diff --git a/ext/Storable/t/tied.t b/ext/Storable/t/tied.t deleted file mode 100644 index 9a7f5711da..0000000000 --- a/ext/Storable/t/tied.t +++ /dev/null @@ -1,215 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw); - -print "1..23\n"; - -($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0); - -package TIED_HASH; - -sub TIEHASH { - my $self = bless {}, shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($key) = @_; - $main::hash_fetch++; - return $self->{$key}; -} - -sub STORE { - my $self = shift; - my ($key, $value) = @_; - $self->{$key} = $value; -} - -sub FIRSTKEY { - my $self = shift; - scalar keys %{$self}; - return each %{$self}; -} - -sub NEXTKEY { - my $self = shift; - return each %{$self}; -} - -package TIED_ARRAY; - -sub TIEARRAY { - my $self = bless [], shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($idx) = @_; - $main::array_fetch++; - return $self->[$idx]; -} - -sub STORE { - my $self = shift; - my ($idx, $value) = @_; - $self->[$idx] = $value; -} - -sub FETCHSIZE { - my $self = shift; - return @{$self}; -} - -package TIED_SCALAR; - -sub TIESCALAR { - my $scalar; - my $self = bless \$scalar, shift; - return $self; -} - -sub FETCH { - my $self = shift; - $main::scalar_fetch++; - return $$self; -} - -sub STORE { - my $self = shift; - my ($value) = @_; - $$self = $value; -} - -package FAULT; - -$fault = 0; - -sub TIESCALAR { - my $pkg = shift; - return bless [@_], $pkg; -} - -sub FETCH { - my $self = shift; - my ($href, $key) = @$self; - $fault++; - untie $href->{$key}; - return $href->{$key} = 1; -} - -package main; - -$a = 'toto'; -$b = \$a; - -$c = tie %hash, TIED_HASH; -$d = tie @array, TIED_ARRAY; -tie $scalar, TIED_SCALAR; - -#$scalar = 'foo'; -#$hash{'attribute'} = \$d; -#$array[0] = $c; -#$array[1] = \$scalar; - -### If I say -### $hash{'attribute'} = $d; -### below, then dump() incorectly dumps the hash value as a string the second -### time it is reached. I have not investigated enough to tell whether it's -### a bug in my dump() routine or in the Perl tieing mechanism. -$scalar = 'foo'; -$hash{'attribute'} = 'plain value'; -$array[0] = \$scalar; -$array[1] = $c; -$array[2] = \@array; - -@tied = (\$scalar, \@array, \%hash); -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar); -@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d, - $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied); - -ok 1, defined($f = freeze(\@a)); - -$dumped = &dump(\@a); -ok 2, 1; - -$root = thaw($f); -ok 3, defined $root; - -$got = &dump($root); -ok 4, 1; - -### Used to see the manifestation of the bug documented above. -### print "original: $dumped"; -### print "--------\n"; -### print "got: $got"; -### print "--------\n"; - -ok 5, $got eq $dumped; - -$g = freeze($root); -ok 6, length($f) == length($g); - -# Ensure the tied items in the retrieved image work -@old = ($scalar_fetch, $array_fetch, $hash_fetch); -@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]}; -@type = qw(SCALAR ARRAY HASH); - -ok 7, tied $$tscalar; -ok 8, tied @{$tarray}; -ok 9, tied %{$thash}; - -@new = ($$tscalar, $tarray->[0], $thash->{'attribute'}); -@new = ($scalar_fetch, $array_fetch, $hash_fetch); - -# Tests 10..15 -for ($i = 0; $i < @new; $i++) { - print "not " unless $new[$i] == $old[$i] + 1; - printf "ok %d\n", 10 + 2*$i; # Tests 10,12,14 - print "not " unless ref $tied[$i] eq $type[$i]; - printf "ok %d\n", 11 + 2*$i; # Tests 11,13,15 -} - -# Check undef ties -my $h = {}; -tie $h->{'x'}, 'FAULT', $h, 'x'; -my $hf = freeze($h); -ok 16, defined $hf; -ok 17, $FAULT::fault == 0; -ok 18, $h->{'x'} == 1; -ok 19, $FAULT::fault == 1; - -my $ht = thaw($hf); -ok 20, defined $ht; -ok 21, $ht->{'x'} == 1; -ok 22, $FAULT::fault == 2; - -{ - package P; - use Storable qw(freeze thaw); - use vars qw($a $b); - $b = "not ok "; - sub TIESCALAR { bless \$a } sub FETCH { "ok " } - tie $a, P; my $r = thaw freeze \$a; $b = $$r; - print $b , 23, "\n"; -} - diff --git a/ext/Storable/t/tied_hook.t b/ext/Storable/t/tied_hook.t deleted file mode 100644 index 8f2846ed6e..0000000000 --- a/ext/Storable/t/tied_hook.t +++ /dev/null @@ -1,242 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw); - -print "1..25\n"; - -($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0); - -package TIED_HASH; - -sub TIEHASH { - my $self = bless {}, shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($key) = @_; - $main::hash_fetch++; - return $self->{$key}; -} - -sub STORE { - my $self = shift; - my ($key, $value) = @_; - $self->{$key} = $value; -} - -sub FIRSTKEY { - my $self = shift; - scalar keys %{$self}; - return each %{$self}; -} - -sub NEXTKEY { - my $self = shift; - return each %{$self}; -} - -sub STORABLE_freeze { - my $self = shift; - $main::hash_hook1++; - return join(":", keys %$self) . ";" . join(":", values %$self); -} - -sub STORABLE_thaw { - my ($self, $cloning, $frozen) = @_; - my ($keys, $values) = split(/;/, $frozen); - my @keys = split(/:/, $keys); - my @values = split(/:/, $values); - for (my $i = 0; $i < @keys; $i++) { - $self->{$keys[$i]} = $values[$i]; - } - $main::hash_hook2++; -} - -package TIED_ARRAY; - -sub TIEARRAY { - my $self = bless [], shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($idx) = @_; - $main::array_fetch++; - return $self->[$idx]; -} - -sub STORE { - my $self = shift; - my ($idx, $value) = @_; - $self->[$idx] = $value; -} - -sub FETCHSIZE { - my $self = shift; - return @{$self}; -} - -sub STORABLE_freeze { - my $self = shift; - $main::array_hook1++; - return join(":", @$self); -} - -sub STORABLE_thaw { - my ($self, $cloning, $frozen) = @_; - @$self = split(/:/, $frozen); - $main::array_hook2++; -} - -package TIED_SCALAR; - -sub TIESCALAR { - my $scalar; - my $self = bless \$scalar, shift; - return $self; -} - -sub FETCH { - my $self = shift; - $main::scalar_fetch++; - return $$self; -} - -sub STORE { - my $self = shift; - my ($value) = @_; - $$self = $value; -} - -sub STORABLE_freeze { - my $self = shift; - $main::scalar_hook1++; - return $$self; -} - -sub STORABLE_thaw { - my ($self, $cloning, $frozen) = @_; - $$self = $frozen; - $main::scalar_hook2++; -} - -package main; - -$a = 'toto'; -$b = \$a; - -$c = tie %hash, TIED_HASH; -$d = tie @array, TIED_ARRAY; -tie $scalar, TIED_SCALAR; - -$scalar = 'foo'; -$hash{'attribute'} = 'plain value'; -$array[0] = \$scalar; -$array[1] = $c; -$array[2] = \@array; -$array[3] = "plaine scalaire"; - -@tied = (\$scalar, \@array, \%hash); -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar); -@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d, - $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied); - -ok 1, defined($f = freeze(\@a)); - -$dumped = &dump(\@a); -ok 2, 1; - -$root = thaw($f); -ok 3, defined $root; - -$got = &dump($root); -ok 4, 1; - -ok 5, $got ne $dumped; # our hooks did not handle refs in array - -$g = freeze($root); -ok 6, length($f) == length($g); - -# Ensure the tied items in the retrieved image work -@old = ($scalar_fetch, $array_fetch, $hash_fetch); -@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]}; -@type = qw(SCALAR ARRAY HASH); - -ok 7, tied $$tscalar; -ok 8, tied @{$tarray}; -ok 9, tied %{$thash}; - -@new = ($$tscalar, $tarray->[0], $thash->{'attribute'}); -@new = ($scalar_fetch, $array_fetch, $hash_fetch); - -# Tests 10..15 -for ($i = 0; $i < @new; $i++) { - ok 10 + 2*$i, $new[$i] == $old[$i] + 1; # Tests 10,12,14 - ok 11 + 2*$i, ref $tied[$i] eq $type[$i]; # Tests 11,13,15 -} - -ok 16, $$tscalar eq 'foo'; -ok 17, $tarray->[3] eq 'plaine scalaire'; -ok 18, $thash->{'attribute'} eq 'plain value'; - -# Ensure hooks were called -ok 19, ($scalar_hook1 && $scalar_hook2); -ok 20, ($array_hook1 && $array_hook2); -ok 21, ($hash_hook1 && $hash_hook2); - -# -# And now for the "blessed ref to tied hash" with "store hook" test... -# - -my $bc = bless \%hash, 'FOO'; # FOO does not exist -> no hook -my $bx = thaw freeze $bc; - -ok 22, ref $bx eq 'FOO'; -my $old_hash_fetch = $hash_fetch; -my $v = $bx->{attribute}; -ok 23, $hash_fetch == $old_hash_fetch + 1; # Still tied - -package TIED_HASH_REF; - - -sub STORABLE_freeze { - my ($self, $cloning) = @_; - return if $cloning; - return('ref lost'); -} - -sub STORABLE_thaw { - my ($self, $cloning, $data) = @_; - return if $cloning; -} - -package main; - -$bc = bless \%hash, 'TIED_HASH_REF'; -$bx = thaw freeze $bc; - -ok 24, ref $bx eq 'TIED_HASH_REF'; -$old_hash_fetch = $hash_fetch; -$v = $bx->{attribute}; -ok 25, $hash_fetch == $old_hash_fetch + 1; # Still tied diff --git a/ext/Storable/t/tied_items.t b/ext/Storable/t/tied_items.t deleted file mode 100644 index bd15e5cc4f..0000000000 --- a/ext/Storable/t/tied_items.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -# -# Tests ref to items in tied hash/array structures. -# - -sub BEGIN { - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - -sub ok; -$^W = 0; - -print "1..8\n"; - -use Storable qw(dclone); - -$h_fetches = 0; - -sub H::TIEHASH { bless \(my $x), "H" } -sub H::FETCH { $h_fetches++; $_[1] - 70 } - -tie %h, "H"; - -$ref = \$h{77}; -$ref2 = dclone $ref; - -ok 1, $h_fetches == 0; -ok 2, $$ref2 eq $$ref; -ok 3, $$ref2 == 7; -ok 4, $h_fetches == 2; - -$a_fetches = 0; - -sub A::TIEARRAY { bless \(my $x), "A" } -sub A::FETCH { $a_fetches++; $_[1] - 70 } - -tie @a, "A"; - -$ref = \$a[78]; -$ref2 = dclone $ref; - -ok 5, $a_fetches == 0; -ok 6, $$ref2 eq $$ref; -ok 7, $$ref2 == 8; -# I don't understand why it's 3 and not 2 -ok 8, $a_fetches == 3; diff --git a/ext/Storable/t/utf8.t b/ext/Storable/t/utf8.t deleted file mode 100644 index 67b79170e5..0000000000 --- a/ext/Storable/t/utf8.t +++ /dev/null @@ -1,58 +0,0 @@ - -#!./perl -w -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - if ($] < 5.006) { - print "1..0 # Skip: no utf8 support\n"; - exit 0; - } - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'st-dump.pl'; -} - -use strict; -sub ok; - -use Storable qw(thaw freeze); - -print "1..6\n"; - -my $x = chr(1234); -ok 1, $x eq ${thaw freeze \$x}; - -# Long scalar -$x = join '', map {chr $_} (0..1023); -ok 2, $x eq ${thaw freeze \$x}; - -# Char in the range 127-255 (probably) in utf8 -$x = chr (175) . chr (256); -chop $x; -ok 3, $x eq ${thaw freeze \$x}; - -# Storable needs to cope if a frozen string happens to be internall utf8 -# encoded - -$x = chr 256; -my $data = freeze \$x; -ok 4, $x eq ${thaw $data}; - -$data .= chr 256; -chop $data; -ok 5, $x eq ${thaw $data}; - - -$data .= chr 256; -# This definately isn't valid -eval {thaw $data}; -ok 6, $@ =~ /corrupt.*characters outside/; diff --git a/ext/Storable/t/utf8hash.t b/ext/Storable/t/utf8hash.t deleted file mode 100644 index 7eac651c6e..0000000000 --- a/ext/Storable/t/utf8hash.t +++ /dev/null @@ -1,197 +0,0 @@ -#!./perl - -sub BEGIN { - if ($] < 5.007) { - print "1..0 # Skip: no utf8 hash key support\n"; - exit 0; - } - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE}){ - if($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - } -} - -use strict; -our $DEBUGME = shift || 0; -use Storable qw(store nstore retrieve thaw freeze); -{ - no warnings; - $Storable::DEBUGME = ($DEBUGME > 1); -} -# Better than no plan, because I was getting out of memory errors, at which -# point Test::More tidily prints up 1..79 as if I meant to finish there. -use Test::More tests=>144; -use bytes (); -my %utf8hash; - -$Storable::canonical = $Storable::canonical; # Shut up a used only once warning. - -for $Storable::canonical (0, 1) { - -# first we generate a nasty hash which keys include both utf8 -# on and off with identical PVs - -no utf8; # we have a naked 8-bit byte below (in Latin 1, anyway) - -# In Latin 1 -ese the below ord() should end up 0xc0 (192), -# in EBCDIC 0x64 (100). Both should end up being UTF-8/UTF-EBCDIC. -my @ords = ( - ord("Á"), # LATIN CAPITAL LETTER A WITH GRAVE - 0x3000, #IDEOGRAPHIC SPACE - ); - -foreach my $i (@ords){ - my $u = chr($i); utf8::upgrade($u); - # warn sprintf "%d,%d", bytes::length($u), is_utf8($u); - my $b = chr($i); utf8::encode($b); - # warn sprintf "%d,%d" ,bytes::length($b), is_utf8($b); - - isnt($u, $b, "equivalence - with utf8flag"); - - $utf8hash{$u} = $utf8hash{$b} = $i; -} - -sub nkeys($){ - my $href = shift; - return scalar keys %$href; -} - -my $nk; -is($nk = nkeys(\%utf8hash), scalar(@ords)*2, - "nasty hash generated (nkeys=$nk)"); - -# now let the show begin! - -my $thawed = thaw(freeze(\%utf8hash)); - -is($nk = nkeys($thawed), - nkeys(\%utf8hash), - "scalar keys \%{\$thawed} (nkeys=$nk)"); -for my $k (sort keys %$thawed){ - is($utf8hash{$k}, $thawed->{$k}, "frozen item chr($utf8hash{$k})"); -} - -my $storage = "utfhash.po"; # po = perl object! -my $retrieved; - -ok((nstore \%utf8hash, $storage), "nstore to $storage"); -ok(($retrieved = retrieve($storage)), "retrieve from $storage"); - -is($nk = nkeys($retrieved), - nkeys(\%utf8hash), - "scalar keys \%{\$retrieved} (nkeys=$nk)"); -for my $k (sort keys %$retrieved){ - is($utf8hash{$k}, $retrieved->{$k}, "nstored item chr($utf8hash{$k})"); -} -unlink $storage; - - -ok((store \%utf8hash, $storage), "store to $storage"); -ok(($retrieved = retrieve($storage)), "retrieve from $storage"); -is($nk = nkeys($retrieved), - nkeys(\%utf8hash), - "scalar keys \%{\$retrieved} (nkeys=$nk)"); -for my $k (sort keys %$retrieved){ - is($utf8hash{$k}, $retrieved->{$k}, "stored item chr($utf8hash{$k})"); -} -$DEBUGME or unlink $storage; - -# On the premis that more tests are good, here are NWC's tests: - -package Hash_Test; - -sub me_second { - return (undef, $_[0]); -} - -package main; - -my $utf8 = "Schlo\xdf" . chr 256; -chop $utf8; - -# Set this to 1 to test the test by bypassing Storable. -my $bypass = 0; - -sub class_test { - my ($object, $package) = @_; - unless ($package) { - is ref $object, 'HASH', "$object is unblessed"; - return; - } - isa_ok ($object, $package); - my ($garbage, $copy) = eval {$object->me_second}; - is $@, "", "check it has correct method"; - cmp_ok $copy, '==', $object, "and that it returns the same object"; -} - -# Thanks to Dan Kogai for the Kanji for "castle" (which he informs me also -# means 'a city' in Mandarin). -my %hash = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, "\x{57CE}"); - -for my $package ('', 'Hash_Test') { - # Run through and sanity check these. - if ($package) { - bless \%hash, $package; - } - for (keys %hash) { - my $l = 0 + /^\w+$/; - my $r = 0 + $hash{$_} =~ /^\w+$/; - cmp_ok ($l, '==', $r); - } - - # Grr. This cperl mode thinks that ${ is a punctuation variable. - # I presume it's punishment for using xemacs rather than emacs. Or OS/2 :-) - my $copy = $bypass ? \%hash : ${thaw freeze \\%hash}; - class_test ($copy, $package); - - for (keys %$copy) { - my $l = 0 + /^\w+$/; - my $r = 0 + $copy->{$_} =~ /^\w+$/; - cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); - } - - - my $bytes = my $char = chr 27182; - utf8::encode ($bytes); - - my $orig = {$char => 1}; - if ($package) { - bless $orig, $package; - } - my $just_utf8 = $bypass ? $orig : ${thaw freeze \$orig}; - class_test ($just_utf8, $package); - cmp_ok (scalar keys %$just_utf8, '==', 1, "1 key in utf8?"); - cmp_ok ($just_utf8->{$char}, '==', 1, "utf8 key present?"); - ok (!exists $just_utf8->{$bytes}, "bytes key absent?"); - - $orig = {$bytes => 1}; - if ($package) { - bless $orig, $package; - } - my $just_bytes = $bypass ? $orig : ${thaw freeze \$orig}; - class_test ($just_bytes, $package); - - cmp_ok (scalar keys %$just_bytes, '==', 1, "1 key in bytes?"); - cmp_ok ($just_bytes->{$bytes}, '==', 1, "bytes key present?"); - ok (!exists $just_bytes->{$char}, "utf8 key absent?"); - - die sprintf "Both have length %d, which is crazy", length $char - if length $char == length $bytes; - - $orig = {$bytes => length $bytes, $char => length $char}; - if ($package) { - bless $orig, $package; - } - my $both = $bypass ? $orig : ${thaw freeze \$orig}; - class_test ($both, $package); - - cmp_ok (scalar keys %$both, '==', 2, "2 keys?"); - cmp_ok ($both->{$bytes}, '==', length $bytes, "bytes key present?"); - cmp_ok ($both->{$char}, '==', length $char, "utf8 key present?"); -} - -} diff --git a/ext/Storable/t/weak.t b/ext/Storable/t/weak.t deleted file mode 100644 index a2be7a10b0..0000000000 --- a/ext/Storable/t/weak.t +++ /dev/null @@ -1,142 +0,0 @@ -#!./perl -w -# -# Copyright 2004, Larry Wall. -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# - -sub BEGIN { - # This lets us distribute Test::More in t/ - unshift @INC, 't'; - require Config; import Config; - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } - - require Scalar::Util; - Scalar::Util->import(qw(weaken isweak)); - if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) { - print("1..0 # Skip: No support for weaken in Scalar::Util\n"); - exit 0; - } -} - -use Test::More 'no_plan'; -use Storable qw (store retrieve freeze thaw nstore nfreeze); -require 'testlib.pl'; -use vars '$file'; -use strict; - -sub tester { - my ($contents, $sub, $testersub, $what) = @_; - # Test that if we re-write it, everything still works: - my $clone = &$sub ($contents); - is ($@, "", "There should be no error extracting for $what"); - &$testersub ($clone, $what); -} - -my $r = {}; -my $s1 = [$r, $r]; -weaken $s1->[1]; -ok (isweak($s1->[1]), "element 1 is a weak reference"); - -my $s0 = [$r, $r]; -weaken $s0->[0]; -ok (isweak($s0->[0]), "element 0 is a weak reference"); - -my $w = [$r]; -weaken $w->[0]; -ok (isweak($w->[0]), "element 0 is a weak reference"); - -package OVERLOADED; - -use overload - '""' => sub { $_[0][0] }; - -package main; - -$a = bless [77], 'OVERLOADED'; - -my $o = [$a, $a]; -weaken $o->[0]; -ok (isweak($o->[0]), "element 0 is a weak reference"); - -my @tests = ( -[$s1, - sub { - my ($clone, $what) = @_; - isa_ok($clone,'ARRAY'); - isa_ok($clone->[0],'HASH'); - isa_ok($clone->[1],'HASH'); - ok(!isweak $clone->[0], "Element 0 isn't weak"); - ok(isweak $clone->[1], "Element 1 is weak"); -} -], -# The weak reference needs to hang around long enough for other stuff to -# be able to make references to it. So try it second. -[$s0, - sub { - my ($clone, $what) = @_; - isa_ok($clone,'ARRAY'); - isa_ok($clone->[0],'HASH'); - isa_ok($clone->[1],'HASH'); - ok(isweak $clone->[0], "Element 0 is weak"); - ok(!isweak $clone->[1], "Element 1 isn't weak"); -} -], -[$w, - sub { - my ($clone, $what) = @_; - isa_ok($clone,'ARRAY'); - if ($what eq 'nothing') { - # We're the original, so we're still a weakref to a hash - isa_ok($clone->[0],'HASH'); - ok(isweak $clone->[0], "Element 0 is weak"); - } else { - is($clone->[0],undef); - } -} -], -[$o, -sub { - my ($clone, $what) = @_; - isa_ok($clone,'ARRAY'); - isa_ok($clone->[0],'OVERLOADED'); - isa_ok($clone->[1],'OVERLOADED'); - ok(isweak $clone->[0], "Element 0 is weak"); - ok(!isweak $clone->[1], "Element 1 isn't weak"); - is ("$clone->[0]", 77, "Element 0 stringifies to 77"); - is ("$clone->[1]", 77, "Element 1 stringifies to 77"); -} -], -); - -foreach (@tests) { - my ($input, $testsub) = @$_; - - tester($input, sub {return shift}, $testsub, 'nothing'); - - ok (defined store($input, $file)); - - # Read the contents into memory: - my $contents = slurp ($file); - - tester($contents, \&store_and_retrieve, $testsub, 'file'); - - # And now try almost everything again with a Storable string - my $stored = freeze $input; - tester($stored, \&freeze_and_thaw, $testsub, 'string'); - - ok (defined nstore($input, $file)); - - tester($contents, \&store_and_retrieve, $testsub, 'network file'); - - $stored = nfreeze $input; - tester($stored, \&freeze_and_thaw, $testsub, 'network string'); -} |