diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..1e5e266 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,1020 @@ +2018-04-27 20:40:00 xsawyerx + version 3.11 + * Fix Strawberry Perl build failures. + +2018-04-21 22:00:00 xsawyerx + Version 3.10 + * Fix binary artifacts from distribution. + +2018-04-21 16:49:00 xsawyerx + Version 3.09 + * Fix "provides" in metadata (META.yml/META.json) to use the Storable + template instead of a small other file (which also didn't exist). + +2018-04-21 11:23:00 xsawyerx + Version 3.08 + * (perl #132849) try to disable core files when deliberatly segfaulting. + * (perl #127743) don't probe Storable limits so much. + * (perl #132893) don't probe for Storable recursion limits on old Win32. + * (perl #132870) workaround VC2017 compiler bug. + * (perl #127743) re-work for debugging builds with MSVC. + * (perl #133039) dont build a Storable.so/.dll with a static perl build. + +2018-02-07 15:08:00 tonyc + Version 3.06 + + * support large object ids. The code in theory supported arrays + with more than 2**32 elements, but references to the elements + emitted at the end of the array with be retrieved as references to + the wrong elements. + * 32-bit object ids over 2**31-1 weren't correctly handled. + * hook object id generation now supports 64-bit ids where needed + * writing 64-bit lengths in network order now works + * reading 64-bit lengths in network order now reads the components + in the correct order. + * retrieving large object tags are now only handled on 64-bit + platforms, large object tags should only be emitted for objects + that are too large for the 32-bit address space, so it was only + wasted code. + * reading 32-bit lengths for LSCALAR and LUTF8STR as unsigned + (perl #131990) + * reading flagged large object hashes didn't read the flags + * treat the 32-bit size of hook data as unsigned, values over 2GB + were treated as large (close to 2**64) parameters to NEWSV(). + (perl #131999) + * added support for hook data over 4GB in size + * zero length data receievd from STORABLE_freeze() no longer + results in an invalid SV being passed to STORABLE_thaw/_attach() + (perl #118551) + * where practical, padding is now cleared when emitting a long + double (perl #131136) + * cache the value of $Storable::DEBUGME (since cperl enabled + Storable TRACEME builds for all -DDEBUGGING builds) + * no longer discard exceptions thrown by + STORABLE_freeze/_thaw/attach() (perl #25933) + * fix dependencies used to build Storable.pm from __Storable__.pm + * add experimental support for freezing/thawing regular + expressions (perl #50608) + * re-work recursion limiting to store the limit in a perl variable + instead of baked into Storable.$so. This allows static Storable + builds to work, and avoids the kind of circular reference on + Storable.$so. + +2017-07-24 13:57:13 rurban + Version 3.05_13 + + * mingw fix: use safe defaults, not segfaulting defaults. + mingw fails on the stacksize binary search, leaving it empty. + +Wed Apr 19 09:11:07 2017 +0200 Reini Urban + Version 3.05_12 + + * enhance stack reserve from 8 to 16 + * fix LD_LIBRARY_PATH usage for CORE + * fixed some coverity warnings and leaks + * added a release make target + +Wed Mar 29 21:04:28 2017 +0200 Reini Urban + Version 3.05_11 + + * croak on sizes read > I32_MAX + * simplify last_op_in_netorder + * protect from empty retrieve_vstring + * protect store_other error buf, potential static + buffer overflow. + +Tue Mar 14 09:52:20 2017 +0100 Reini Urban + Version 3.05_10 + + * CORE-only improvements to stacksize + +Thu Mar 9 19:20:19 2017 +0100 Reini Urban + Version 3.05_09 + + * compute the stacksizes, improve cleanup within croak + from stack exhaustion. + * added stack_depth and stack_depth_hash getters. + +Wed Mar 8 21:03:43 CET 2017 Reini Urban + Version 3.05_08 + + * finetune the max stack limit, for C++, DEBUGGING and 32bit. + * fix t/blessed.t for cperl5.22 + +Sun Mar 5 13:36:47 2017 +0100 Reini Urban + Version 3.05_07 + + * Fixed a podchecker issue + +Sun Mar 5 11:42:04 2017 +0100 Reini Urban + Version 3.05_06 + + * Fixed wrong recursion depth error with large arrays containing + another array. + L<[cperl #257]|https://github.com/perl11/cperl/issues/257> + +Thu Feb 2 12:40:44 2017 +0100 Reini Urban + Version 3.05_05 + + * Add leak tests for [cpan #97316], [perl #121928] + * Limit the max recursion depth to 1200 on 32bit systems. + We have no max_depth option yet, as in JSON::XS. + +Thu Feb 2 11:59:21 2017 +0100 Reini Urban + Version 3.05_04 + + * Fix retrieve_tied_array which fails since 5.16 + [cpan #84705] + * Improve t/blessed.t in the creation of sv_yes/sv_no + with threaded perls. + +Tue Jan 31 02:55:30 2017 +0100 Reini Urban + Version 3.05_03 + + * Tune t/recurse.t stack-overflow limit more. + +Mon Jan 30 19:50:29 2017 +0100 Reini Urban + Version 3.05_02 + + * Tune t/recurse.t stack-overflow limit. Small 64bit systems overflow + even with depth 3000, where 32bit are ok. + +Mon Jan 30 15:13:38 2017 +0100 Reini Urban + Version 3.05_01 + + * Protect against stack overflows with nested arrays and hashes + [cpan #97526]. This imposes a new limit to your nested structures, + but JSON::XS has a limit of 512. We use a max_depth of 3000 for the + typical stack limit of 8k. + + +Sun Jan 29 11:36:43 2017 +0100 Reini Urban + Version 3.05 + + * Protect against classname len overflow on the stack + and 2x on the heap with retrieve_bless and retrieve_hook. + A serious security issue with malcrafted storable files or buffers, + but p5p accepts no CVE on Storable attacks. See RT #130635 + (reported by JD). + * Fix NULL ptr SEGVs with retrieve_code and retrieve_other. + See RT #130098 (reported and fixed by JD) + * Fix wrong huge LOBJECT support, broken since 3.00c. + Repro with `export PERL_TEST_MEMORY=8` + * Fix the few remaining 2-arg open calls. + * Portability and backport fixes back to 5.6.2 + +Sat Jan 7 09:01:29 2017 +0100 Reini Urban + Version 3.04c + + * fix printf types and warnings, esp. for 32bit use64bitint + * Change sv_setpvn(…, "…", …) to sv_setpvs(…, "…") + +Tue Jul 26 11:49:33 2016 +1000 Tony Cook + Version 3.03c + + * remove . from @INC when loading optional modules + +Sun Nov 20 18:06:45 2016 +0100 Reini Urban + Version 3.02c + + * Fix -Wc++11-compat warnings, fix -Wchar-subscripts + +Fri Sep 16 01:32:59 2016 +0200 Reini Urban + Version 3.01c + + * Added warn_security("Movable-Type CVE-2015-1592 Storable metasploit attack") + when detecting the third destructive metasploit vector, + thawing bless \"mt-config.cgi", "CGITempFile". + +Thu Mar 31 17:10:27 2016 +0200 Reini Urban + Version 3.00c + + * Added support for u64 strings, arrays and hashes >2G + via a new LOBJECT tag. This is for 32bit systems and lengths + between 2GB and 4GB (I32-U32), and 64bit (>I32). + * Bumped STORABLE_BIN_MINOR and STORABLE_BIN_WRITE_MINOR from 10 to 11 + * fix parallel tests, use unique filenames. + * fixed 2 instances of 2arg open, + * added optional flag arguments to skip tie and bless on retrieve/thaw, + * added SECURITY WARNING and Large data support to docs + * compute CAN_FLOCK at compile-time + * reformat everything consistently + * enable DEBUGME tracing and asserts with -DDEBUGGING + * fix all 64 bit compiler warnings + * added some abstraction methods to avoid code duplication + +?????? p5p + Version 2.65 + + * Replace multiple 'use vars' by 'our' + * remove Config dependency + +Wed Jul 2 16:25:25 IST 2014 Abhijit Menon-Sen + Version 2.51 + + * [perl #121928] Fix memory leak for dclone inside freeze hook + (Alex Solovey) + * Do not call DESTROY for empty objects + (Vladimir Timofeev) + * Other bugfixes + +Sat Jul 13 18:34:27 IST 2013 Abhijit Menon-Sen + Version 2.45 + + * [perl #118829] Memory leaks in STORABLE_attach + (Vladimir Timofeev) + * [perl #118139] Don't SEGV during global destruction + (Nicholas Clark, report/test from Reini Urban) + * Added security warnings section (Steffen Mueller) + * Update INSTALLDIRS to favour installation in 'site' + (James E Keenan) + +Tue 11 Sep 06:51:11 IST 2012 Abhijit Menon-Sen + Version 2.39 + + Various bugfixes, including compatibility fixes for older + versions of Perl and vstring handling. + +Sun 3 Jul 09:10:11 IST 2011 Abhijit Menon-Sen + Version 2.29 + + Various bugfixes, notably including preventing nfreeze from + incorrectly stringifying integers. + +Fri 3 Dec 14:12:32 GMT 2010 David Leadbeater + Version 2.25 + + Support for serializing coderefs containing UTF-8. + +Fri Nov 12 10:52:19 IST 2010 Abhijit Menon-Sen + + Version 2.24 + + Performance improvement for overloaded classes from Benjamin + Holzman. + +Fri Nov 12 10:36:22 IST 2010 Abhijit Menon-Sen + + Version 2.23 + + Release the latest version from the Perl repository. + +Thu Aug 6 10:55:50 IST 2009 Abhijit Menon-Sen + + Version 2.21 + + Includes hints/hpux.pl that was inadvertently left out of 2.20. + +Mon May 18 09:38:20 IST 2009 Abhijit Menon-Sen + + 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 + + Version 2.18 + + Compile fixes for older Perls. (No functional changes.) + +Sat Nov 17 02:12:12 IST 2007 Abhijit Menon-Sen + + Version 2.17 + + Various broken tests fixed. (No functional changes.) + +Sat Mar 31 06:11:06 IST 2007 Abhijit Menon-Sen + + 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 + + Version 2.15 + + Minor changes to address a couple of compile problems. + +Mon Apr 25 07:29:14 IST 2005 Abhijit Menon-Sen + + Version 2.14 + + 1. Store weak references + 2. Add STORABLE_attach hook. + +Thu Jun 17 12:26:43 BST 2004 Nicholas Clark + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + Version 2.05 + + Adds support for CODE references from Slaven Rezic + . + +Fri Jun 7 23:55:41 BST 2002 Nicholas Clark + + Version 2.04 + + Bug fix from Radu Greab (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 reoccurrence of this sort of goof are always welcome. + +Thu May 30 20:31:08 BST 2002 Nicholas Clark + + 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 explicitly 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + Version 1.0.2. + + Fixed spelling in README. + + Added lock_store, lock_nstore, and lock_retrieve (advisory locking) + after a proposal from Erik Haugan . + + 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 + + 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 + + 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 + + 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 + + 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 + for spotting it first. + +Sun Aug 13 22:12:59 MEST 2000 Raphael Manfredi + + 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 + + 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 + + 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 + + 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 , + preventing Perl's patchlevel from being included, which is + needed starting from 5.6. + +Tue May 12 09:15:15 METDST 1998 Raphael Manfredi + + Fixed shared "undef" bug in hashes, which did not remain shared + through store/retrieve. + +Thu Feb 10 19:48:16 MET 2000 Raphael Manfredi + + 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 + + Forgot to update VERSION + +Tue Oct 19 21:25:02 MEST 1999 Raphael Manfredi + + 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 + + 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 + + changed my e-mail to pobox. + + mentioned it is not thread-safe. + + updated version number. + + uses new internal PL_* naming convention. + +Fri Jul 3 13:38:16 METDST 1998 Raphael Manfredi + + 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 + + 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 + + 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 explicitly, by storing &sv_yes + as such, explicitly. + + 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 + + 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 + + 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 + + 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 + + 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 + + I said SvPOK() had changed to SvPOKp(), but that was a lie... + +Wed Apr 8 13:14:29 METDST 1998 Raphael Manfredi + + Wrote sizeof(SV *) instead of sizeof(I32) when portable, which + in effect mangled the object tags and prevented portability + across 32/64 bit architectures! + +Wed Mar 25 14:57:02 MET 1998 Raphael Manfredi + + 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 benchmarking 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 + + Don't use any '_' in version number. + +Tue Jan 13 17:51:50 MET 1998 Raphael Manfredi + + 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 + + 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 + + Updated version number + + Added freeze/thaw interface and dclone. + +Fri May 16 10:45:47 METDST 1997 Raphael Manfredi + + 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 + + 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 + + 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 + + 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 + + Random code fixes. + +Wed Jan 22 15:19:56 MET 1997 Raphael Manfredi + + 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/MANIFEST b/MANIFEST new file mode 100644 index 0000000..d30b94e --- /dev/null +++ b/MANIFEST @@ -0,0 +1,66 @@ +__Storable__.pm +ChangeLog +hints/gnukfreebsd.pl +hints/gnuknetbsd.pl +hints/hpux.pl +hints/linux.pl +Makefile.PL +MANIFEST This list of files +META.json Module JSON meta-data (added by MakeMaker) +META.yml Module meta-data (added by MakeMaker) +ppport.h +README +stacksize +Storable.pm.PL +Storable.xs +t/attach.t +t/attach_errors.t +t/attach_singleton.t +t/blessed.t +t/canonical.t +t/circular_hook.t +t/code.t +t/compat01.t +t/compat06.t +t/croak.t +t/CVE-2015-1592.t +t/dclone.t +t/destroy.t +t/downgrade.t +t/file_magic.t +t/flags.t +t/forgive.t +t/freeze.t +t/HAS_ATTACH.pm +t/HAS_HOOK.pm +t/HAS_OVERLOAD.pm +t/huge.t +t/hugeids.t +t/integer.t +t/interwork56.t +t/just_plain_nasty.t +t/leaks.t +t/lock.t +t/make_56_interwork.pl +t/make_downgrade.pl +t/make_overload.pl +t/malice.t +t/overload.t +t/recurse.t +t/regexp.t +t/restrict.t +t/retrieve.t +t/robust.t +t/sig_die.t +t/st-dump.pl +t/store.t +t/testlib.pl +t/threads.t +t/tied.t +t/tied_hook.t +t/tied_items.t +t/tied_reify.t +t/tied_store.t +t/utf8.t +t/utf8hash.t +t/weak.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..4bcc673 --- /dev/null +++ b/META.json @@ -0,0 +1,53 @@ +{ + "abstract" : "persistence for Perl data structures", + "author" : [ + "Perl 5 Porters" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Storable", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "XSLoader" : "0" + } + } + }, + "provides" : { + "Storable" : { + "file" : "__Storable__.pm", + "version" : "3.11" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "http://rt.perl.org/perlbug/" + } + }, + "version" : "3.11", + "x_serialization_backend" : "JSON::PP version 2.27400_02" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..119eff3 --- /dev/null +++ b/META.yml @@ -0,0 +1,29 @@ +--- +abstract: 'persistence for Perl data structures' +author: + - 'Perl 5 Porters' +build_requires: + ExtUtils::MakeMaker: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Storable +no_index: + directory: + - t + - inc +provides: + Storable: + file: __Storable__.pm + version: '3.11' +requires: + XSLoader: '0' +resources: + bugtracker: http://rt.perl.org/perlbug/ +version: '3.11' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..a5d9e66 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,132 @@ +# +# Copyright (c) 1995-2000, Raphael Manfredi +# Copyright (c) 2017, Reini Urban +# +# You may redistribute only under the same terms as Perl 5, as specified +# in the README file that comes with the distribution. +# + +use strict; +use warnings; +use ExtUtils::MakeMaker 6.31; +use Config; +use File::Copy qw(move copy); +use File::Spec; + +unlink "lib/Storable/Limit.pm"; + +my $limit_pm = File::Spec->catfile('lib', 'Storable', 'Limit.pm'); + +my $pm = { 'Storable.pm' => '$(INST_ARCHLIB)/Storable.pm' }; +unless ($ENV{PERL_CORE}) { + # the core Makefile takes care of this for core builds + $pm->{$limit_pm} = '$(INST_ARCHLIB)/Storable/Limit.pm'; +} + +WriteMakefile( + NAME => 'Storable', + AUTHOR => 'Perl 5 Porters', + LICENSE => 'perl', + DISTNAME => "Storable", +# We now ship this in t/ +# PREREQ_PM => { 'Test::More' => '0.41' }, + PL_FILES => { }, # prevent default behaviour + PM => $pm, + PREREQ_PM => { XSLoader => 0 }, + INSTALLDIRS => ($] >= 5.007 && $] < 5.012) ? 'perl' : 'site', + VERSION_FROM => '__Storable__.pm', + ABSTRACT_FROM => '__Storable__.pm', + ($ExtUtils::MakeMaker::VERSION > 6.45 ? + (META_MERGE => { resources => + { bugtracker => 'http://rt.perl.org/perlbug/' }, + provides => { + 'Storable' => { + file => '__Storable__.pm', + version => MM->parse_version('__Storable__.pm'), + }, + }, + + }, + ) : ()), + dist => { SUFFIX => 'gz', COMPRESS => 'gzip -f' }, + clean => { FILES => 'Storable-* Storable.pm lib' }, +); + +# Unlink the .pm file included with the distribution +1 while unlink "Storable.pm"; + +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 +} + +# compute the maximum stacksize, before and after linking +package MY; + +# FORCE finish of INST_DYNAMIC, avoid loading the old Storable (failed XS_VERSION check) +sub xlinkext { + my $s = shift->SUPER::linkext(@_); + $s =~ s|( :: .*)| $1 FORCE stacksize|; + $s +} + +sub depend { + my $extra_deps = ""; + my $options = ""; + if ($ENV{PERL_CORE}) { + $options = "--core"; + } + else { + # blib.pm needs arch/lib + $extra_deps = ' Storable.pm'; + } + my $linktype = uc($_[0]->{LINKTYPE}); + " +$limit_pm : stacksize \$(INST_$linktype)$extra_deps + \$(MKPATH) \$(INST_LIB) + \$(FULLPERLRUNINST) stacksize $options + +release : dist + git tag \$(VERSION) + cpan-upload \$(DISTVNAME).tar\$(SUFFIX) + git push + git push --tags +" +} + +sub test { + my ($self, %attr) = @_; + + my $out = $self->SUPER::test(%attr); + + if ($ENV{PERL_CORE}) { + $out =~ s!^(test(?:db)?_(?:static|dynamic)\b.*)!$1 $limit_pm!gm; + } + + $out; +} + +sub postamble { +' +all :: Storable.pm + $(NOECHO) $(NOOP) + +Storable.pm :: Storable.pm.PL __Storable__.pm + $(PERLRUN) Storable.pm.PL +' +} diff --git a/README b/README new file mode 100644 index 0000000..f63ace9 --- /dev/null +++ b/README @@ -0,0 +1,114 @@ + Storable 3.05c + Copyright (c) 1995-2000, Raphael Manfredi + Copyright (c) 2001-2004, Larry Wall + Copyright (c) 2016,2017 cPanel Inc + +------------------------------------------------------------------------ + 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 partially done by the perl5-porters, and for cperl by cPanel. +| We thank Raphael Manfredi for providing us with this very useful module. ++======================================================================= + +The Storable extension brings persistence 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 embedded POD manual page in Storable.pm. + +Storable was written by Raphael Manfredi +Maintenance is now done by cperl, https://github.com/rurban/Storable/ +Note that p5p still ships an old broken version, without stack overflow +protection and large object support. As long as you don't store overlarge +objects, they are compatible. + +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 + Ulrich Pfeifer + Benjamin A. Holzman + Andrew Ford + Gisle Aas + Jeff Gresham + Murray Nesbitt + Albert N. Micheev + Marc Lehmann + Justin Banks + Jarkko Hietaniemi (AGAIN, as perl 5.7.0 Pumpkin!) + Todd Rinaldo and JD Lightsey + for optional disabling tie and bless for increased security. + Reini Urban for the 3.0x >2G support and rewrite + JD Lightsey + +for their contributions. + +A Japanese translation of this man page is available at the Japanized +Perl Resources Project . +------------------------------------------------------------------------ + +The perl5-porters would like to thank + + Raphael Manfredi + +According to the perl5.8 Changes file, the following people have helped +bring you this Storable release: + + Abhijit Menon-Sen + Andreas J. Koenig + Archer Sully + Craig A. Berry + Dan Kogai + Doug MacEachern + Gurusamy Sarathy + H.Merijn Brand + Jarkko Hietaniemi + Mark Bixby + Michael Stevens + Mike Guy + Nicholas Clark + Peter J. Farley III + Peter Prymmer + Philip Newton + Raphael Manfredi + Robin Barker + Radu Greab + Tim Bunce + VMSperlers + Yitzchak Scott-Thoennes diff --git a/Storable.pm.PL b/Storable.pm.PL new file mode 100644 index 0000000..df979c0 --- /dev/null +++ b/Storable.pm.PL @@ -0,0 +1,35 @@ +use strict; +use warnings; + +use Config; + +my $template; +{ # keep all the code in an external template to keep it easy to update + local $/; + open my $FROM, '<', '__Storable__.pm' or die $!; + $template = <$FROM>; + close $FROM or die $!; +} + +sub CAN_FLOCK { + return + $Config{'d_flock'} || + $Config{'d_fcntl_can_lock'} || + $Config{'d_lockf'} + ? 1 : 0; +} + +my $CAN_FLOCK = CAN_FLOCK(); + +# populate the sub and preserve it if used outside +$template =~ s{^sub CAN_FLOCK;.*$}{sub CAN_FLOCK { ${CAN_FLOCK} } # computed by Storable.pm.PL}m; +# alternatively we could remove the sub +#$template =~ s{^sub CAN_FLOCK;.*$}{}m; +# replace local function calls to hardcoded value +$template =~ s{&CAN_FLOCK}{${CAN_FLOCK}}g; + +{ + open my $OUT, '>', 'Storable.pm' or die $!; + print {$OUT} $template or die $!; + close $OUT or die $!; +} diff --git a/Storable.xs b/Storable.xs new file mode 100644 index 0000000..6a90e24 --- /dev/null +++ b/Storable.xs @@ -0,0 +1,7881 @@ +/* -*- c-basic-offset: 4 -*- + * + * Fast store and retrieve mechanism. + * + * Copyright (c) 1995-2000, Raphael Manfredi + * Copyright (c) 2016, 2017 cPanel Inc + * Copyright (c) 2017 Reini Urban + * + * 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 +#include +#include + +#ifndef PATCHLEVEL +#include /* Perl's one, needed since 5.6 */ +#endif + +#if !defined(PERL_VERSION) || PERL_VERSION < 10 || (PERL_VERSION == 10 && PERL_SUBVERSION < 1) +#define NEED_PL_parser +#define NEED_sv_2pv_flags +#define NEED_load_module +#define NEED_vload_module +#define NEED_newCONSTSUB +#define NEED_newSVpvn_flags +#define NEED_newRV_noinc +#include "ppport.h" /* handle old perls */ +#endif + +#ifdef DEBUGGING +#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 HvSHAREKEYS_off +#define HvSHAREKEYS_off(hv) /* Ignore */ +#endif + +/* perl <= 5.8.2 needs this */ +#ifndef SvIsCOW +# define SvIsCOW(sv) 0 +#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 HvPLACEHOLDERS_get +# define HvPLACEHOLDERS_get HvPLACEHOLDERS +#endif + +#ifndef HvTOTALKEYS +# define HvTOTALKEYS(hv) HvKEYS(hv) +#endif +/* 5.6 */ +#ifndef HvUSEDKEYS +# define HvUSEDKEYS(hv) HvKEYS(hv) +#endif + +#ifdef SVf_IsCOW +# define SvTRULYREADONLY(sv) SvREADONLY(sv) +#else +# define SvTRULYREADONLY(sv) (SvREADONLY(sv) && !SvIsCOW(sv)) +#endif + +#ifndef SvPVCLEAR +# define SvPVCLEAR(sv) sv_setpvs(sv, "") +#endif + +#ifndef strEQc +# define strEQc(s,c) memEQ(s, ("" c ""), sizeof(c)) +#endif + +#ifdef DEBUGME + +#ifndef DASSERT +#define DASSERT +#endif + +/* + * TRACEME() will only output things when the $Storable::DEBUGME is true, + * using the value traceme cached in the context. + * + * + * TRACEMED() directly looks at the variable, for use before traceme has been + * updated. + */ + +#define TRACEME(x) \ + STMT_START { \ + if (cxt->traceme) \ + { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ + } STMT_END + +#define TRACEMED(x) \ + STMT_START { \ + if (SvTRUE(get_sv("Storable::DEBUGME", GV_ADD))) \ + { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ + } STMT_END + +#define INIT_TRACEME \ + STMT_START { \ + cxt->traceme = SvTRUE(get_sv("Storable::DEBUGME", GV_ADD)); \ + } STMT_END + +#else +#define TRACEME(x) +#define TRACEMED(x) +#define INIT_TRACEME +#endif /* DEBUGME */ + +#ifdef DASSERT +#define ASSERT(x,y) \ + STMT_START { \ + if (!(x)) { \ + PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \ + __FILE__, (int)__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 forthcoming (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_VSTRING C(29) /* vstring forthcoming (small) */ +#define SX_LVSTRING C(30) /* vstring forthcoming (large) */ +#define SX_SVUNDEF_ELEM C(31) /* array element set to &PL_sv_undef */ +#define SX_REGEXP C(32) /* Regexp */ +#define SX_LOBJECT C(33) /* Large object: string, array or hash (size >2G) */ +#define SX_LAST C(34) /* invalid. marker only */ + +/* + * 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 persistence + * is required. Hence the aptr pointer. + */ +struct extendable { + char *arena; /* Will hold hash key strings, resized as needed */ + STRLEN asiz; /* Size of aforementioned 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 determined 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 */ + +/* + * Make the tag type 64-bit on 64-bit platforms. + * + * If the tag number is low enough it's stored as a 32-bit value, but + * with very large arrays and hashes it's possible to go over 2**32 + * scalars. + */ + +typedef STRLEN ntag_t; + +/* used for where_is_undef - marks an unset value */ +#define UNSET_NTAG_T (~(ntag_t)0) + +/* + * The following "thread-safe" related defines were contributed by + * Murray Nesbitt 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 +#ifndef SvVOK +#define VSTRING_CROAK() CROAK(("Cannot retrieve vstring 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 + +/* do we need/want to clear padding on NVs? */ +#if defined(LONG_DOUBLEKIND) && defined(USE_LONG_DOUBLE) +# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN +# define NV_PADDING (NVSIZE - 10) +# else +# define NV_PADDING 0 +# endif +#else +/* This is kind of a guess - it means we'll get an unneeded clear on 128-bit NV + but an upgraded perl will fix that +*/ +# if NVSIZE > 8 +# define NV_CLEAR +# endif +# define NV_PADDING 0 +#endif + +typedef union { + NV nv; + U8 bytes[sizeof(NV)]; +} NV_bytes; + +/* Needed for 32bit with lengths > 2G - 4G, and 64bit */ +#if PTRSIZE > 4 +#define HAS_U64 +#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 */ + ntag_t 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 restricted 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 */ + SV *recur_sv; /* check only one recursive SV */ + int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */ + int flags; /* controls whether to bless or tie objects */ + IV recur_depth; /* avoid stack overflows RT #97526 */ + IV max_recur_depth; /* limit for recur_depth */ + IV max_recur_depth_hash; /* limit for recur_depth for hashes */ +#ifdef DEBUGME + int traceme; /* TRACEME() produces output */ +#endif +} stcxt_t; + +#define RECURSION_TOO_DEEP() \ + (cxt->max_recur_depth != -1 && ++cxt->recur_depth > cxt->max_recur_depth) +#define RECURSION_TOO_DEEP_HASH() \ + (cxt->max_recur_depth_hash != -1 && ++cxt->recur_depth > cxt->max_recur_depth_hash) +#define MAX_DEPTH_ERROR "Max. recursion depth with nested structures exceeded" + +static int storable_free(pTHX_ SV *sv, MAGIC* mg); + +static MGVTBL vtbl_storable = { + NULL, /* get */ + NULL, /* set */ + NULL, /* len */ + NULL, /* clear */ + storable_free, +#ifdef MGf_COPY + NULL, /* copy */ +#endif +#ifdef MGf_DUP + NULL, /* dup */ +#endif +#ifdef MGf_LOCAL + NULL /* local */ +#endif +}; + +/* From Digest::MD5. */ +#ifndef sv_magicext +# define sv_magicext(sv, obj, type, vtbl, name, namlen) \ + THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen) +static MAGIC *THX_sv_magicext(pTHX_ + SV *sv, SV *obj, int type, + MGVTBL const *vtbl, char const *name, I32 namlen) +{ + MAGIC *mg; + if (obj || namlen) + /* exceeded intended usage of this reserve implementation */ + return NULL; + Newxz(mg, 1, MAGIC); + mg->mg_virtual = (MGVTBL*)vtbl; + mg->mg_type = type; + mg->mg_ptr = (char *)name; + mg->mg_len = -1; + (void) SvUPGRADE(sv, SVt_PVMG); + mg->mg_moremagic = SvMAGIC(sv); + SvMAGIC_set(sv, mg); + SvMAGICAL_off(sv); + mg_magical(sv); + return mg; +} +#endif + +#define NEW_STORABLE_CXT_OBJ(cxt) \ + STMT_START { \ + SV *self = newSV(sizeof(stcxt_t) - 1); \ + SV *my_sv = newRV_noinc(self); \ + sv_magicext(self, NULL, PERL_MAGIC_ext, &vtbl_storable, NULL, 0); \ + 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 = 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); \ + assert(perinterp_sv); \ + 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) ((STRLEN) (x) & 0xffffffffUL)) +#endif + +/* + * PTR2TAG(x) + * + * Convert a pointer into an ntag_t. + */ + +#define PTR2TAG(x) ((ntag_t)(x)) + +#define TAG2PTR(x, type) ((y)(x)) + +/* + * 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 oL(x) (x) +#define oC(x) (x = 0) +#define CRAY_HACK +#else +#define oI(x) (x) +#define oS(x) (x) +#define oL(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) { \ + if (x >= I32_MAX) \ + CROAK(("Too large size > I32_MAX")); \ + TRACEME(("** extending kbuf to %d bytes (had %d)", \ + (int)(x+1), (int)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) \ + ((STRLEN) (((STRLEN) (x) + MMASK) & ~MMASK)) +#define trunc_int(x) \ + ((STRLEN) ((STRLEN) (x) & ~(sizeof(int)-1))) +#define int_aligned(x) \ + ((STRLEN)(x) == trunc_int(x)) + +#define MBUF_INIT(x) \ + STMT_START { \ + if (!mbase) { \ + TRACEME(("** allocating mbase of %d bytes", MGROW)); \ + New(10003, mbase, (int)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 { \ + STRLEN nsz = (STRLEN) round_mgrow((x)+msiz); \ + STRLEN offset = mptr - mbase; \ + ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \ + TRACEME(("** extending mbase from %ld to %ld bytes (wants %ld new)", \ + (long)msiz, nsz, (long)(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_PUTLONG(l) \ + STMT_START { \ + MBUF_CHK(8); \ + memcpy(mptr, &l, 8); \ + mptr += 8; \ + } STMT_END +#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_REGEXP 7 +#define svis_OTHER 8 + +/* + * 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 + +/* + * flags to allow blessing and/or tieing data the data we load + */ +#define FLAG_BLESS_OK 2 +#define FLAG_TIE_OK 4 + +/* + * Flags for SX_REGEXP. + */ + +#define SHR_U32_RE_LEN 0x01 + +/* + * 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 + explicitly 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 redefinition 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 + +#ifndef INT32_MAX +# define INT32_MAX 2147483647 +#endif +#if IVSIZE > 4 && !defined(INT64_MAX) +# define INT64_MAX 9223372036854775807LL +#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 11 /* Binary minor "version" */ + +#if (PATCHLEVEL <= 5) +#define STORABLE_BIN_WRITE_MINOR 4 +#elif !defined (SvVOK) +/* + * Perl 5.6.0-5.8.0 can do weak references, but not vstring magic. +*/ +#define STORABLE_BIN_WRITE_MINOR 8 +#elif PATCHLEVEL >= 19 +/* Perl 5.19 takes away the special meaning of PL_sv_undef in arrays. */ +/* With 3.x we added LOBJECT */ +#define STORABLE_BIN_WRITE_MINOR 11 +#else +#define STORABLE_BIN_WRITE_MINOR 9 +#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 + +#define WRITE_U64(x) \ + STMT_START { \ + ASSERT(sizeof(x) == sizeof(UV), ("writing an UV")); \ + if (!cxt->fio) \ + MBUF_PUTLONG(x); \ + else if (PerlIO_write(cxt->fio, oL(&x), \ + oS(sizeof(x))) != oS(sizeof(x))) \ + return -1; \ + } STMT_END + +#ifdef HAS_HTONL +#define WLEN(x) \ + STMT_START { \ + ASSERT(sizeof(x) == sizeof(int), ("WLEN writing an int")); \ + 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 + +# ifdef HAS_U64 + +#define W64LEN(x) \ + STMT_START { \ + ASSERT(sizeof(x) == 8, ("W64LEN writing a U64")); \ + if (cxt->netorder) { \ + U32 buf[2]; \ + buf[1] = htonl(x & 0xffffffffUL); \ + buf[0] = htonl(x >> 32); \ + if (!cxt->fio) \ + MBUF_PUTLONG(buf); \ + else if (PerlIO_write(cxt->fio, buf, \ + sizeof(buf)) != sizeof(buf)) \ + return -1; \ + } else { \ + if (!cxt->fio) \ + MBUF_PUTLONG(x); \ + else if (PerlIO_write(cxt->fio,oI(&x), \ + oS(sizeof(x))) != oS(sizeof(x))) \ + return -1; \ + } \ + } STMT_END + +# else + +#define W64LEN(x) CROAK(("No 64bit UVs")) + +# endif + +#else +#define WLEN(x) WRITE_I32(x) +#ifdef HAS_U64 +#define W64LEN(x) WRITE_U64(x) +#else +#define W64LEN(x) CROAK(("no 64bit UVs")) +#endif +#endif + +#define WRITE(x,y) \ + STMT_START { \ + if (!cxt->fio) \ + MBUF_WRITE(x,y); \ + else if (PerlIO_write(cxt->fio, x, y) != (SSize_t)y) \ + return -1; \ + } STMT_END + +#define STORE_PV_LEN(pv, len, small, large) \ + STMT_START { \ + if (len <= LG_SCALAR) { \ + int ilen = (int) len; \ + unsigned char clen = (unsigned char) len; \ + PUTMARK(small); \ + PUTMARK(clen); \ + if (len) \ + WRITE(pv, ilen); \ + } else if (sizeof(len) > 4 && len > INT32_MAX) { \ + PUTMARK(SX_LOBJECT); \ + PUTMARK(large); \ + W64LEN(len); \ + WRITE(pv, len); \ + } else { \ + int ilen = (int) len; \ + PUTMARK(large); \ + WLEN(ilen); \ + WRITE(pv, ilen); \ + } \ + } 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(). We + * actually use this to represent nonexistent elements, for historical + * reasons. + */ +#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) != (SSize_t)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) != (SSize_t)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 + +#ifdef HAS_U64 + +# if defined(HAS_NTOHL) +# define Sntohl(x) ntohl(x) +# elif BYTEORDER == 0x87654321 || BYTEORDER == 0x4321 +# define Sntohl(x) (x) +# else +static U32 Sntohl(U32 x) { + return ((x & 0xFF) << 24) + ((x * 0xFF00) << 8) + + ((x & 0xFF0000) >> 8) + ((x & 0xFF000000) >> 24); +} +# endif + +# define READ_U64(x) \ + STMT_START { \ + ASSERT(sizeof(x) == 8, ("R64LEN reading a U64")); \ + if (cxt->netorder) { \ + U32 buf[2]; \ + READ((void *)buf, sizeof(buf)); \ + (x) = ((UV)Sntohl(buf[0]) << 32) + Sntohl(buf[1]); \ + } \ + else { \ + READ(&(x), sizeof(x)); \ + } \ + } STMT_END + +#endif + +/* + * SEEN() 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) + * + * SEEN0() is a short-cut where stash is always NULL. + * + * The _NN variants dont check for y being null + */ +#define SEEN0_NN(y,i) \ + STMT_START { \ + if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) \ + : SvREFCNT_inc(y)) == 0) \ + return (SV *) 0; \ + TRACEME(("aseen(#%d) = 0x%" UVxf " (refcnt=%d)", \ + (int)cxt->tagnum-1, \ + PTR2UV(y), (int)SvREFCNT(y)-1)); \ + } STMT_END + +#define SEEN0(y,i) \ + STMT_START { \ + if (!y) \ + return (SV *) 0; \ + SEEN0_NN(y,i); \ + } STMT_END + +#define SEEN_NN(y,stash,i) \ + STMT_START { \ + SEEN0_NN(y,i); \ + if (stash) \ + BLESS((SV *)(y), (HV *)(stash)); \ + } STMT_END + +#define SEEN(y,stash,i) \ + STMT_START { \ + if (!y) \ + return (SV *) 0; \ + SEEN_NN(y,stash, i); \ + } STMT_END + +/* + * Bless 's' in 'p', via a temporary reference, required by sv_bless(). + * "A" magic is added before the sv_bless for overloaded classes, this avoids + * an expensive call to S_reset_amagic in sv_bless. + */ +#define BLESS(s,stash) \ + STMT_START { \ + SV *ref; \ + if (cxt->flags & FLAG_BLESS_OK) { \ + TRACEME(("blessing 0x%" UVxf " in %s", PTR2UV(s), \ + HvNAME_get(stash))); \ + ref = newRV_noinc(s); \ + if (cxt->in_retrieve_overloaded && Gv_AMG(stash)) { \ + cxt->in_retrieve_overloaded = 0; \ + SvAMAGIC_on(ref); \ + } \ + (void) sv_bless(ref, stash); \ + SvRV_set(ref, NULL); \ + SvREFCNT_dec(ref); \ + } \ + else { \ + TRACEME(("not blessing 0x%" UVxf " in %s", PTR2UV(s), \ + (HvNAME_get(stash)))); \ + } \ + } 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); + +#define UNSEE() \ + STMT_START { \ + av_pop(cxt->aseen); \ + cxt->tagnum--; \ + } STMT_END + +/* + * 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_regexp(pTHX_ stcxt_t *cxt, SV *sv); +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_regexp, /* svis_REGEXP */ + (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); +static SV *retrieve_lobject(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname); + +/* helpers for U64 lobjects */ + +static SV *get_lstring(pTHX_ stcxt_t *cxt, UV len, int isutf8, const char *cname); +#ifdef HAS_U64 +static SV *get_larray(pTHX_ stcxt_t *cxt, UV len, const char *cname); +static SV *get_lhash(pTHX_ stcxt_t *cxt, UV len, int hash_flags, const char *cname); +static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags); +#endif +static int store_hentry(pTHX_ stcxt_t *cxt, HV* hv, UV i, HE *he, unsigned char hash_flags); + +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_TIED_ARRAY */ + (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */ + (sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_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_VSTRING not supported */ + (sv_retrieve_t)retrieve_other, /* SX_LVSTRING not supported */ + (sv_retrieve_t)retrieve_other, /* SX_SVUNDEF_ELEM not supported */ + (sv_retrieve_t)retrieve_other, /* SX_REGEXP */ + (sv_retrieve_t)retrieve_other, /* SX_LOBJECT not supported */ + (sv_retrieve_t)retrieve_other, /* SX_LAST */ +}; + +static SV *retrieve_hook_common(pTHX_ stcxt_t *cxt, const char *cname, int large); + +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 SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_svundef_elem(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_TIED_ARRAY */ + (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */ + (sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_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_vstring, /* SX_VSTRING */ + (sv_retrieve_t)retrieve_lvstring, /* SX_LVSTRING */ + (sv_retrieve_t)retrieve_svundef_elem,/* SX_SVUNDEF_ELEM */ + (sv_retrieve_t)retrieve_regexp, /* SX_REGEXP */ + (sv_retrieve_t)retrieve_lobject, /* SX_LOBJECT */ + (sv_retrieve_t)retrieve_other, /* SX_LAST */ +}; + +#define RETRIEVE(c,x) ((x) >= SX_LAST ? retrieve_other : *(c)->retrieve_vtbl[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; + INIT_TRACEME; + 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->recur_sv = NULL; + cxt->recur_depth = 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) +{ + INIT_TRACEME; + + 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 bottleneck 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 */ + + cxt->max_recur_depth = SvIV(get_sv("Storable::recursion_limit", GV_ADD)); + cxt->max_recur_depth_hash = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD)); +} + +/* + * clean_store_context + * + * Clean store context by + */ +static void clean_store_context(pTHX_ stcxt_t *cxt) +{ + HE *he; + + TRACEMED(("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 */ + HeVAL(he) = &PL_sv_undef; + } +#endif + + if (cxt->hclass) { + hv_iterinit(cxt->hclass); + while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall */ + 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 + * exceptional 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) +{ + INIT_TRACEME; + + 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 correspondence 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 = UNSET_NTAG_T; /* 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 */ + cxt->in_retrieve_overloaded = 0; + + cxt->max_recur_depth = SvIV(get_sv("Storable::recursion_limit", GV_ADD)); + cxt->max_recur_depth_hash = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD)); +} + +/* + * clean_retrieve_context + * + * Clean retrieve context by + */ +static void clean_retrieve_context(pTHX_ stcxt_t *cxt) +{ + TRACEMED(("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 = UNSET_NTAG_T; + + 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 */ + + cxt->in_retrieve_overloaded = 0; + reset_context(cxt); +} + +/* + * clean_context + * + * A workaround for the CROAK bug: cleanup the last context. + */ +static void clean_context(pTHX_ stcxt_t *cxt) +{ + TRACEMED(("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; + + ASSERT(!parent_cxt->s_dirty, ("parent context clean")); + + NEW_STORABLE_CXT_OBJ(cxt); + TRACEMED(("allocate_context")); + + 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); + + TRACEMED(("free_context")); + + ASSERT(!cxt->s_dirty, ("clean context")); + ASSERT(prev, ("not freeing root context")); + assert(prev); + + SvREFCNT_dec(cxt->my_sv); + SET_STCXT(prev); + + ASSERT(cxt, ("context not void")); +} + +/*** + *** Predicates. + ***/ + +/* these two functions are currently only used within asserts */ +#ifdef DASSERT +/* + * 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); +} +#endif + +/* + * 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; + + assert(cxt); + 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); +#ifdef DEBUGME + dSTCXT; +#endif + + /* + * 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_inc((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); + PERL_UNUSED_ARG(method); + (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); + PERL_UNUSED_ARG(method); + (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); +#ifdef DEBUGME + dSTCXT; +#endif + + 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; +#ifdef DEBUGME + dSTCXT; +#endif + + 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); + SSize_t cnt = AvFILLp(av) + 1; + SSize_t i; + XPUSHs(ary[0]); /* Frozen string */ + for (i = 1; i < cnt; i++) { + TRACEME(("pushing arg #%d (0x%" UVxf ")...", + (int)i, PTR2UV(ary[i]))); + XPUSHs(sv_2mortal(newRV_inc(ary[i]))); + } + } + PUTBACK; + + TRACEME(("calling...")); + count = 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; +#ifdef DEBUGME + dSTCXT; +#endif + + TRACEME(("array_call (cloning=%d)", cloning)); + + ENTER; + SAVETMPS; + + PUSHMARK(sp); + XPUSHs(obj); /* Target object */ + XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */ + PUTBACK; + + count = 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; +} + +#if PERL_VERSION < 15 +static void +cleanup_recursive_av(pTHX_ AV* av) { + SSize_t i = AvFILLp(av); + SV** arr = AvARRAY(av); + if (SvMAGICAL(av)) return; + while (i >= 0) { + if (arr[i]) { +#if PERL_VERSION < 14 + arr[i] = NULL; +#else + SvREFCNT_dec(arr[i]); +#endif + } + i--; + } +} + +#ifndef SvREFCNT_IMMORTAL +#ifdef DEBUGGING + /* exercise the immortal resurrection code in sv_free2() */ +# define SvREFCNT_IMMORTAL 1000 +#else +# define SvREFCNT_IMMORTAL ((~(U32)0)/2) +#endif +#endif + +static void +cleanup_recursive_hv(pTHX_ HV* hv) { + SSize_t i = HvTOTALKEYS(hv); + HE** arr = HvARRAY(hv); + if (SvMAGICAL(hv)) return; + while (i >= 0) { + if (arr[i]) { + SvREFCNT(HeVAL(arr[i])) = SvREFCNT_IMMORTAL; + arr[i] = NULL; /* let it leak. too dangerous to clean it up here */ + } + i--; + } +#if PERL_VERSION < 8 + ((XPVHV*)SvANY(hv))->xhv_array = NULL; +#else + HvARRAY(hv) = NULL; +#endif + HvTOTALKEYS(hv) = 0; +} +static void +cleanup_recursive_rv(pTHX_ SV* sv) { + if (sv && SvROK(sv)) + SvREFCNT_dec(SvRV(sv)); +} +static void +cleanup_recursive_data(pTHX_ SV* sv) { + if (SvTYPE(sv) == SVt_PVAV) { + cleanup_recursive_av(aTHX_ (AV*)sv); + } + else if (SvTYPE(sv) == SVt_PVHV) { + cleanup_recursive_hv(aTHX_ (HV*)sv); + } + else { + cleanup_recursive_rv(aTHX_ sv); + } +} +#endif + +/* + * 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; +} + +/*** + *** Specific store routines. + ***/ + +/* + * store_ref + * + * Store a reference. + * Layout is SX_REF or SX_OVERLOAD . + */ +static int store_ref(pTHX_ stcxt_t *cxt, SV *sv) +{ + int retval; + 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); + + TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth, + PTR2UV(cxt->recur_sv))); + if (cxt->entry && cxt->recur_sv == sv) { + if (RECURSION_TOO_DEEP()) { +#if PERL_VERSION < 15 + cleanup_recursive_data(aTHX_ (SV*)sv); +#endif + CROAK((MAX_DEPTH_ERROR)); + } + } + cxt->recur_sv = sv; + + retval = store(aTHX_ cxt, sv); + if (cxt->entry && cxt->recur_sv == sv && cxt->recur_depth > 0) { + TRACEME(("recur_depth --%" IVdf, cxt->recur_depth)); + --cxt->recur_depth; + } + return retval; +} + +/* + * store_scalar + * + * Store a scalar. + * + * Layout is SX_LSCALAR , SX_SCALAR or SX_UNDEF. + * SX_LUTF8STR and SX_UTF8STR are used for UTF-8 strings. + * The section is omitted if is 0. + * + * For vstrings, the vstring portion is stored first with + * SX_LVSTRING or SX_VSTRING , followed by + * SX_(L)SCALAR or SX_(L)UTF8STR with the actual PV. + * + * If integer or double, the layout is SX_INTEGER or SX_DOUBLE . + * Small integers (within [-127, +127]) are stored as SX_BYTE . + * + * For huge strings use SX_LOBJECT SX_type SX_U64 + */ +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", (int)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) > (UV)0x7FFFFFFF) || +#endif + (iv > (IV)0x7FFFFFFF) || (iv < -(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_bytes nv; +#ifdef NV_CLEAR + /* if we can't tell if there's padding, clear the whole NV and hope the + compiler leaves the padding alone + */ + Zero(&nv, 1, NV_bytes); +#endif +#if (PATCHLEVEL <= 6) + nv.nv = SvNV(sv); + /* + * Watch for number being an integer in disguise. + */ + if (nv.nv == (NV) (iv = I_V(nv.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.nv = SvNV(sv); +#endif + + if (cxt->netorder) { + TRACEME(("double %" NVff " stored as string", nv.nv)); + goto string_readlen; /* Share code below */ + } +#if NV_PADDING + Zero(nv.bytes + NVSIZE - NV_PADDING, NV_PADDING, char); +#endif + + PUTMARK(SX_DOUBLE); + WRITE(&nv, sizeof(nv)); + + TRACEME(("ok (double 0x%" UVxf ", value = %" NVff ")", PTR2UV(sv), nv.nv)); + + } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) { +#ifdef SvVOK + MAGIC *mg; +#endif + UV 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: + +#ifdef SvVOK + if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) { + /* The macro passes this by address, not value, and a lot of + called code assumes that it's 32 bits without checking. */ + const SSize_t len = mg->mg_len; + STORE_PV_LEN((const char *)mg->mg_ptr, + len, SX_VSTRING, SX_LVSTRING); + } +#endif + + wlen = (Size_t)len; + if (SvUTF8 (sv)) + STORE_UTF8STR(pv, wlen); + else + STORE_SCALAR(pv, wlen); + TRACEME(("ok (scalar 0x%" UVxf " '%s', length = %" UVuf ")", + PTR2UV(sv), len >= 2048 ? "" : SvPVX(sv), + (UV)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 followed by each item, in increasing index order. + * Each item is stored as . + */ +static int store_array(pTHX_ stcxt_t *cxt, AV *av) +{ + SV **sav; + UV len = av_len(av) + 1; + UV i; + int ret; + + TRACEME(("store_array (0x%" UVxf ")", PTR2UV(av))); + +#ifdef HAS_U64 + if (len > 0x7fffffffu) { + /* + * Large array by emitting SX_LOBJECT 1 U64 data + */ + PUTMARK(SX_LOBJECT); + PUTMARK(SX_ARRAY); + W64LEN(len); + TRACEME(("lobject size = %lu", (unsigned long)len)); + } else +#endif + { + /* + * Normal array by emitting SX_ARRAY, followed by the array length. + */ + I32 l = (I32)len; + PUTMARK(SX_ARRAY); + WLEN(l); + TRACEME(("size = %d", (int)l)); + } + + TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth, + PTR2UV(cxt->recur_sv))); + if (cxt->entry && cxt->recur_sv == (SV*)av) { + if (RECURSION_TOO_DEEP()) { + /* with <= 5.14 it recurses in the cleanup also, needing 2x stack size */ +#if PERL_VERSION < 15 + cleanup_recursive_data(aTHX_ (SV*)av); +#endif + CROAK((MAX_DEPTH_ERROR)); + } + } + cxt->recur_sv = (SV*)av; + + /* + * Now store each item recursively. + */ + + for (i = 0; i < len; i++) { + sav = av_fetch(av, i, 0); + if (!sav) { + TRACEME(("(#%d) nonexistent item", (int)i)); + STORE_SV_UNDEF(); + continue; + } +#if PATCHLEVEL >= 19 + /* In 5.19.3 and up, &PL_sv_undef can actually be stored in + * an array; it no longer represents nonexistent elements. + * Historically, we have used SX_SV_UNDEF in arrays for + * nonexistent elements, so we use SX_SVUNDEF_ELEM for + * &PL_sv_undef itself. */ + if (*sav == &PL_sv_undef) { + TRACEME(("(#%d) undef item", (int)i)); + cxt->tagnum++; + PUTMARK(SX_SVUNDEF_ELEM); + continue; + } +#endif + TRACEME(("(#%d) item", (int)i)); + if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall */ + return ret; + } + + if (cxt->entry && cxt->recur_sv == (SV*)av && cxt->recur_depth > 0) { + TRACEME(("recur_depth --%" IVdf, cxt->recur_depth)); + --cxt->recur_depth; + } + 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 followed by each key/value pair, in random order. + * Values are stored as . + * Keys are stored as , the section being omitted + * if length is 0. + * + * For a "fancy" hash (restricted or utf8 keys): + * + * Layout is SX_FLAG_HASH followed by each key/value pair, + * in random order. + * Values are stored as . + * Keys are stored as , the section being omitted + * if length is 0. + * Currently the only hash flag is "restricted" + * Key flags are as for hv.h + */ +static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) +{ + dVAR; + UV len = (UV)HvTOTALKEYS(hv); + Size_t 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); + + /* + * Signal hash by emitting SX_HASH, followed by the table length. + * Max number of keys per perl version: + * IV - 5.12 + * STRLEN 5.14 - 5.24 (size_t: U32/U64) + * SSize_t 5.22c - 5.24c (I32/I64) + * U32 5.25c - + */ + + if (len > 0x7fffffffu) { /* keys > I32_MAX */ + /* + * Large hash: SX_LOBJECT type hashflags? U64 data + * + * Stupid limitation: + * Note that perl5 can store more than 2G keys, but only iterate + * over 2G max. (cperl can) + * We need to manually iterate over it then, unsorted. + * But until perl itself cannot do that, skip that. + */ + TRACEME(("lobject size = %lu", (unsigned long)len)); +#ifdef HAS_U64 + PUTMARK(SX_LOBJECT); + if (flagged_hash) { + PUTMARK(SX_FLAG_HASH); + PUTMARK(hash_flags); + } else { + PUTMARK(SX_HASH); + } + W64LEN(len); + return store_lhash(aTHX_ cxt, hv, hash_flags); +#else + /* <5.12 you could store larger hashes, but cannot iterate over them. + So we reject them, it's a bug. */ + CROAK(("Cannot store large objects on a 32bit system")); +#endif + } else { + I32 l = (I32)len; + if (flagged_hash) { + TRACEME(("store_hash (0x%" UVxf ") (flags %x)", PTR2UV(hv), + (unsigned int)hash_flags)); + PUTMARK(SX_FLAG_HASH); + PUTMARK(hash_flags); + } else { + TRACEME(("store_hash (0x%" UVxf ")", PTR2UV(hv))); + PUTMARK(SX_HASH); + } + WLEN(l); + TRACEME(("size = %d, used = %d", (int)l, (int)HvUSEDKEYS(hv))); + } + + TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth, + PTR2UV(cxt->recur_sv))); + if (cxt->entry && cxt->recur_sv == (SV*)hv) { + if (RECURSION_TOO_DEEP_HASH()) { +#if PERL_VERSION < 15 + cleanup_recursive_data(aTHX_ (SV*)hv); +#endif + CROAK((MAX_DEPTH_ERROR)); + } + } + cxt->recur_sv = (SV*)hv; + + /* + * Save possible iteration state via each() on that table. + * + * Note that perl as of 5.24 *can* store more than 2G keys, but *not* + * iterate over it. + * Lengths of hash keys are also limited to I32, which is good. + */ + + 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(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 + av_store(av, i, hv_iterkeysv(he)); + } + + 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", (int)flags)); + flags = SHV_K_PLACEHOLDER; +#else + return 1; +#endif + } + + /* + * Store value first. + */ + + TRACEME(("(#%d) value 0x%" UVxf, (int)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) + && SvTRULYREADONLY(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", (int)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'", (int)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++) { +#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); + + if (val == 0) + return 1; /* Internal error, not I/O error */ + + if ((ret = store_hentry(aTHX_ cxt, hv, i, he, hash_flags))) + goto out; +#if 0 + /* Implementation of restricted hashes isn't nicely + abstracted: */ + flags = (((hash_flags & SHV_RESTRICTED) + && SvTRULYREADONLY(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, (int)i, PTR2UV(val))); + + if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall */ + 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", (int)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'", (int)i, key)); + } + if (flags & SHV_K_ISSV) { + int ret; + if ((ret = store(aTHX_ cxt, key_sv))) + goto out; + } else { + WLEN(len); + if (len) + WRITE(key, len); + } +#endif + } + } + + TRACEME(("ok (hash 0x%" UVxf ")", PTR2UV(hv))); + + out: + if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) { + TRACEME(("recur_depth --%" IVdf , cxt->recur_depth)); + --cxt->recur_depth; + } + HvRITER_set(hv, riter); /* Restore hash iterator state */ + HvEITER_set(hv, eiter); + + return ret; +} + +static int store_hentry(pTHX_ + stcxt_t *cxt, HV* hv, UV i, HE *he, unsigned char hash_flags) +{ + int ret = 0; + SV* val = hv_iterval(hv, he); + int flagged_hash = ((SvREADONLY(hv) +#ifdef HAS_HASH_KEY_FLAGS + || HvHASKFLAGS(hv) +#endif + ) ? 1 : 0); + unsigned char flags = (((hash_flags & SHV_RESTRICTED) + && SvTRULYREADONLY(val)) + ? SHV_K_LOCKED : 0); +#ifndef DEBUGME + PERL_UNUSED_ARG(i); +#endif + if (val == &PL_sv_placeholder) { + flags |= SHV_K_PLACEHOLDER; + val = &PL_sv_undef; + } + + /* + * Store value first. + */ + + TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val))); + + { + HEK* hek = HeKEY_hek(he); + I32 len = HEK_LEN(hek); + SV *key_sv = NULL; + char *key = 0; + + if ((ret = store(aTHX_ cxt, val))) + return ret; + if (len == HEf_SVKEY) { + 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", (int)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'", (int)i, key)); + } + if (flags & SHV_K_ISSV) { + if ((ret = store(aTHX_ cxt, key_sv))) + return ret; + } else { + WLEN(len); + if (len) + WRITE(key, len); + } + } + return ret; +} + + +#ifdef HAS_U64 +/* + * store_lhash + * + * Store a overlong hash table, with >2G keys, which we cannot iterate + * over with perl5. xhv_eiter is only I32 there. (only cperl can) + * and we also do not want to sort it. + * So we walk the buckets and chains manually. + * + * type, len and flags are already written. + */ + +static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags) +{ + dVAR; + int ret = 0; + Size_t i; + UV ix = 0; + HE** array; +#ifdef DEBUGME + UV len = (UV)HvTOTALKEYS(hv); +#endif + if (hash_flags) { + TRACEME(("store_lhash (0x%" UVxf ") (flags %x)", PTR2UV(hv), + (int) hash_flags)); + } else { + TRACEME(("store_lhash (0x%" UVxf ")", PTR2UV(hv))); + } + TRACEME(("size = %" UVuf ", used = %" UVuf, len, (UV)HvUSEDKEYS(hv))); + + TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth, + PTR2UV(cxt->recur_sv))); + if (cxt->entry && cxt->recur_sv == (SV*)hv) { + if (RECURSION_TOO_DEEP_HASH()) { +#if PERL_VERSION < 15 + cleanup_recursive_data(aTHX_ (SV*)hv); +#endif + CROAK((MAX_DEPTH_ERROR)); + } + } + cxt->recur_sv = (SV*)hv; + + array = HvARRAY(hv); + for (i = 0; i <= (Size_t)HvMAX(hv); i++) { + HE* entry = array[i]; + if (!entry) continue; + if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags))) + return ret; + while ((entry = HeNEXT(entry))) { + if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags))) + return ret; + } + } + if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) { + TRACEME(("recur_depth --%" IVdf, cxt->recur_depth)); + --cxt->recur_depth; + } + assert(ix == len); + return ret; +} +#endif + +/* + * store_code + * + * Store a code reference. + * + * Layout is SX_CODE 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; + STRLEN len; + STRLEN count, reallen; + SV *text, *bdeparse; + + TRACEME(("store_code (0x%" UVxf ")", PTR2UV(cv))); + + if ( + cxt->deparse == 0 || + (cxt->deparse < 0 && + !(cxt->deparse = + SvTRUE(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, newSVpvs("B::Deparse"), newSVnv(0.61)); + SPAGAIN; + + ENTER; + SAVETMPS; + + /* + * create the B::Deparse object + */ + + PUSHMARK(sp); + XPUSHs(newSVpvs_flags("B::Deparse", SVs_TEMP)); + 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", (int)len)); + TRACEME(("code = %s", SvPV_nolen(text))); + + /* + * Now store the source code. + */ + + if(SvUTF8 (text)) + STORE_UTF8STR(SvPV_nolen(text), len); + else + STORE_SCALAR(SvPV_nolen(text), len); + + FREETMPS; + LEAVE; + + TRACEME(("ok (code)")); + + return 0; +#endif +} + +#if PERL_VERSION < 8 +# define PERL_MAGIC_qr 'r' /* precompiled qr// regex */ +# define BFD_Svs_SMG_OR_RMG SVs_RMG +#elif ((PERL_VERSION==8) && (PERL_SUBVERSION >= 1) || (PERL_VERSION>8)) +# define BFD_Svs_SMG_OR_RMG SVs_SMG +# define MY_PLACEHOLDER PL_sv_placeholder +#else +# define BFD_Svs_SMG_OR_RMG SVs_RMG +# define MY_PLACEHOLDER PL_sv_undef +#endif + +static int get_regexp(pTHX_ stcxt_t *cxt, SV* sv, SV **re, SV **flags) { + dSP; + SV* rv; +#if PERL_VERSION >= 12 + CV *cv = get_cv("re::regexp_pattern", 0); +#else + CV *cv = get_cv("Storable::_regexp_pattern", 0); +#endif + I32 count; + + assert(cv); + + ENTER; + SAVETMPS; + rv = sv_2mortal((SV*)newRV_inc(sv)); + PUSHMARK(sp); + XPUSHs(rv); + PUTBACK; + /* optimize to call the XS directly later */ + count = call_sv((SV*)cv, G_ARRAY); + SPAGAIN; + if (count < 2) + CROAK(("re::regexp_pattern returned only %d results", count)); + *flags = POPs; + SvREFCNT_inc(*flags); + *re = POPs; + SvREFCNT_inc(*re); + + PUTBACK; + FREETMPS; + LEAVE; + + return 1; +} + +static int store_regexp(pTHX_ stcxt_t *cxt, SV *sv) { + SV *re = NULL; + SV *flags = NULL; + const char *re_pv; + const char *flags_pv; + STRLEN re_len; + STRLEN flags_len; + U8 op_flags = 0; + + if (!get_regexp(aTHX_ cxt, sv, &re, &flags)) + return -1; + + re_pv = SvPV(re, re_len); + flags_pv = SvPV(flags, flags_len); + + if (re_len > 0xFF) { + op_flags |= SHR_U32_RE_LEN; + } + + PUTMARK(SX_REGEXP); + PUTMARK(op_flags); + if (op_flags & SHR_U32_RE_LEN) { + U32 re_len32 = re_len; + WLEN(re_len32); + } + else + PUTMARK(re_len); + WRITE(re_pv, re_len); + PUTMARK(flags_len); + WRITE(flags_pv, flags_len); + + return 0; +} + +/* + * 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 , where + * 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 further + * 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 + * SX_TIED_IDX + */ +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", (int)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 [ ] + * + * where indicates how long , and 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: + * + * + * + * + * and when the form is used (classname already seen), the "large + * classname" bit in indicates how large the is. + * + * The serialized string returned by the hook is of length and comes + * next. It is an opaque string for us. + * + * Those 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
being flags with bits set to indicate the object type + * and that recursion was indeed needed: + * + * SX_HOOK
+ * + * 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 . + * + * When storing a blessed ref to a tied variable, the following format is + * used: + * + * SX_HOOK ... [ ] + * + * The first indication carries an object of type SHT_EXTRA, and the + * real object type is held in the 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 */ +#ifdef HAS_U64 + int need_large_oids = 0; +#endif + + TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), (int)cxt->tagnum)); + + /* + * Determine object type on 2 bits. + */ + + switch (type) { + case svis_REF: + 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 to store the type), and an + * byte flag will be emitted after the FIRST 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_inc(sv); /* Temporary reference */ + av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */ + 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) { + /* free empty list returned by the hook */ + av_undef(av); + sv_free((SV *) av); + + /* + * 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; + } + } + +#ifdef HAS_U64 + if (count > I32_MAX) { + CROAK(("Too many references returned by STORABLE_freeze()")); + } +#endif + + /* + * 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", (int)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] [] */ + if (!recursed++) { +#ifdef HAS_U64 + if (len2 > INT32_MAX) + PUTMARK(SX_LOBJECT); +#endif + 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 (!fake_tag) + CROAK(("Could not serialize item #%d from hook in %s", + (int)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", + (int)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))); +#ifdef HAS_U64 + if ((U32)PTR2TAG(tag) != PTR2TAG(tag)) + need_large_oids = 1; +#endif + } + + /* + * 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 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, (int)classnum)); + classnum = -1; /* Mark: we must store classname */ + } else { + TRACEME(("already seen class %s, ID = %d", classname, (int)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; +#ifdef HAS_U64 + if (need_large_oids) + flags |= SHF_LARGE_LISTLEN; +#endif + + /* + * We're ready to emit either serialized form: + * + * SX_HOOK [ ] + * SX_HOOK [ ] + * + * 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 [] */ + if (!recursed) { +#ifdef HAS_U64 + if (len2 > INT32_MAX) + PUTMARK(SX_LOBJECT); +#endif + PUTMARK(SX_HOOK); + PUTMARK(flags); + if (obj_type == SHT_EXTRA) + PUTMARK(eflags); + } else + PUTMARK(flags); + + /* or */ + 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 */ + } + + /* */ +#ifdef HAS_U64 + if (len2 > INT32_MAX) { + W64LEN(len2); + } + else +#endif + if (flags & SHF_LARGE_STRLEN) { + U32 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 */ + + /* [ ] */ + if (flags & SHF_HAS_LIST) { + int len3 = count - 1; + if (flags & SHF_LARGE_LISTLEN) { +#ifdef HAS_U64 + int tlen3 = need_large_oids ? -len3 : len3; + WLEN(tlen3); +#else + WLEN(len3); +#endif + } + 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. + * Which is wrong... if we have more than 2**32 SVs we can get ids over + * the 32-bit limit. + */ + + for (i = 1; i < count; i++) { +#ifdef HAS_U64 + if (need_large_oids) { + ntag_t tag = PTR2TAG(ary[i]); + W64LEN(tag); + TRACEME(("object %d, tag #%" UVuf, i-1, (UV)tag)); + } + else +#endif + { + 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))); + + /* + * [] + */ + if ((ret = store(aTHX_ cxt, mg->mg_obj))) + 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 + * + * where indicates whether 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 seen is remembered and indexed, so that the next time + * an object in the blessed in the same is stored, the following + * will be emitted: + * + * SX_IX_BLESS + * + * where is the classname index, stored on 0 or 4 bytes depending + * on the high-order bit in flag (same encoding as above for ). + */ +static int store_blessed( + pTHX_ + stcxt_t *cxt, + SV *sv, + int type, + HV *pkg) +{ + SV *hook; + char *classname; + I32 len; + 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, (int)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, (int)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, + (int)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 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) +{ + STRLEN 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 + (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); + if (len < 80) + 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: +#if PERL_VERSION <= 10 + if ((SvFLAGS(sv) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) + == (SVs_OBJECT|BFD_Svs_SMG_OR_RMG) + && mg_find(sv, PERL_MAGIC_qr)) { + return svis_REGEXP; + } +#endif + case SVt_PVLV: /* Workaround for perl5.004_04 "LVALUE" bug */ + if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) == + (SVs_GMG|SVs_SMG|SVs_RMG) && + (mg_find(sv, 'p'))) + return svis_TIED_ITEM; + /* FALL THROUGH */ +#if PERL_VERSION < 9 + case SVt_PVBM: +#endif + if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) == + (SVs_GMG|SVs_SMG|SVs_RMG) && + (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_INVLIST: */ +#endif +#if PERL_VERSION > 10 + case SVt_REGEXP: + return svis_REGEXP; +#endif + default: + break; + } + + return svis_OTHER; +} + +/* + * store + * + * Recursively store objects pointed to by the sv to the specified file. + * + * Layout is or SX_OBJECT 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 . + */ +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) { + ntag_t 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 = PTR2TAG(((char *)svh)-1); +#else + tagval = PTR2TAG(*svh); +#endif +#ifdef HAS_U64 + + /* older versions of Storable streat the tag as a signed value + used in an array lookup, corrupting the data structure. + Ensure only a newer Storable will be able to parse this tag id + if it's over the 2G mark. + */ + if (tagval > I32_MAX) { + + TRACEME(("object 0x%" UVxf " seen as #%" UVuf, PTR2UV(sv), + (UV)tagval)); + + PUTMARK(SX_LOBJECT); + PUTMARK(SX_OBJECT); + W64LEN(tagval); + return 0; + } + else +#endif + { + I32 ltagval; + + ltagval = htonl((I32)tagval); + + TRACEME(("object 0x%" UVxf " seen as #%d", PTR2UV(sv), + ntohl(ltagval))); + + PUTMARK(SX_OBJECT); + WRITE_I32(ltagval); + 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), (int)cxt->tagnum, (int)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), + (int)SvREFCNT(sv), sv_reftype(sv, FALSE))); + + return ret; +} + +/* + * magic_write + * + * Write magic number and system information into the file. + * Layout is [ + * ] where is the length of the byteorder hexa string. + * All size and lengths are written as single characters here. + * + * Note that no byte ordering info is emitted when 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(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")); + + TRACEMED(("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. + */ + + assert(cxt); + 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); + + INIT_TRACEME; + + 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 behind 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); + + TRACEME(("do_store returns %d", status)); + + /* + * 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); + + return status == 0; +} + +/*** + *** Memory stores. + ***/ + +/* + * mbuf2sv + * + * Build a new SV out of the content of the internal memory buffer. + */ +static SV *mbuf2sv(pTHX) +{ + dSTCXT; + + assert(cxt); + return newSVpv(mbase, MBUF_SIZE()); +} + +/*** + *** 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) +{ + PERL_UNUSED_ARG(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 with SX_IX_BLESS already read. + * 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; + + PERL_UNUSED_ARG(cname); + TRACEME(("retrieve_idx_blessed (#%d)", (int)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", (int)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 with SX_BLESS already read. + * can be coded on either 1 or 5 bytes. + */ +static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname) +{ + U32 len; + SV *sv; + char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ + char *classname = buf; + char *malloced_classname = NULL; + + PERL_UNUSED_ARG(cname); + TRACEME(("retrieve_blessed (#%d)", (int)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 %ld bytes for class name", (long)len+1)); + if (len > I32_MAX) + CROAK(("Corrupted classname length %lu", (long)len)); + PL_nomemok = TRUE; /* handle error by ourselves */ + New(10003, classname, len+1, char); + PL_nomemok = FALSE; + if (!classname) + CROAK(("Out of memory with len %ld", (long)len)); + PL_nomemok = FALSE; + malloced_classname = classname; + } + SAFEPVREAD(classname, (I32)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, + (int)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 [ ] + * 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 marker with the recursion bit cleared. + * + * If the first byte contains a type of SHT_EXTRA, then the real type + * is held in the byte, and if the object is tied, the serialized + * magic object comes at the very end: + * + * SX_HOOK ... [ ] + * + * 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_common(pTHX_ stcxt_t *cxt, const char *cname, int large) +{ + U32 len; + char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ + char *classname = buf; + unsigned int flags; + STRLEN len2; + SV *frozen; + I32 len3 = 0; + AV *av = 0; + SV *hook; + SV *sv; + SV *rv; + GV *attach; + HV *stash; + int obj_type; + int clone = cxt->optype & ST_CLONE; + char mtype = '\0'; + unsigned int extra_type = 0; +#ifdef HAS_U64 + int has_large_oids = 0; +#endif + + PERL_UNUSED_ARG(cname); + TRACEME(("retrieve_hook (#%d)", (int)cxt->tagnum)); + ASSERT(!cname, ("no bless-into class given here, got %s", cname)); + +#ifndef HAS_U64 + assert(!large); + PERL_UNUSED_ARG(large); +#endif + + /* + * 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 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 */ + } + SEEN0_NN(sv, 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", (int)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); + + TRACEME(("** allocating %ld bytes for class name", (long)len+1)); + if (len > I32_MAX) /* security */ + CROAK(("Corrupted classname length %lu", (long)len)); + else if (len > LG_BLESS) { /* security: signed len */ + PL_nomemok = TRUE; /* handle error by ourselves */ + New(10003, classname, len+1, char); + PL_nomemok = FALSE; + if (!classname) + CROAK(("Out of memory with len %u", (unsigned)len+1)); + malloced_classname = classname; + } + + SAFEPVREAD(classname, (I32)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() + */ + +#ifdef HAS_U64 + if (large) { + READ_U64(len2); + } + else +#endif + if (flags & SHF_LARGE_STRLEN) { + U32 len32; + RLEN(len32); + len2 = len32; + } + else + GETMARK(len2); + + frozen = NEWSV(10002, len2 ? len2 : 1); + 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", (int)len2)); + + /* + * Decode object-ID list length, if present. + */ + + if (flags & SHF_HAS_LIST) { + if (flags & SHF_LARGE_LISTLEN) { + RLEN(len3); + if (len3 < 0) { +#ifdef HAS_U64 + ++has_large_oids; + len3 = -len3; +#else + CROAK(("Large object ids in hook data not supported on 32-bit platforms")); +#endif + + } + } + 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", (int)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 correspondence + * 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 */ + ntag_t tag; + SV **svh; + SV *xsv; + +#ifdef HAS_U64 + if (has_large_oids) { + READ_U64(tag); + } + else { + U32 tmp; + READ_I32(tmp); + tag = ntohl(tmp); + } +#else + READ_I32(tag); + tag = ntohl(tag); +#endif + + 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); + } + } + + /* + * Look up the STORABLE_attach hook + * If blessing is disabled, just return what we've got. + */ + if (!(cxt->flags & FLAG_BLESS_OK)) { + TRACEME(("skipping bless because flags is %d", cxt->flags)); + return sv; + } + + /* + * Bless the object and look up the STORABLE_thaw hook. + */ + stash = gv_stashpv(classname, GV_ADD); + + /* Handle attach case; again can't use pkg_can because it only + * caches one method */ + attach = gv_fetchmethod_autoload(stash, "STORABLE_attach", FALSE); + if (attach && isGV(attach)) { + SV* attached; + SV* attach_hook = newRV_inc((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); + /* Free memory after a call */ + SvREFCNT_dec(rv); + SvREFCNT_dec(frozen); + av_undef(av); + sv_free((SV *) av); + SvREFCNT_dec(attach_hook); + if (attached && + SvROK(attached) && + sv_derived_from(attached, classname) + ) { + UNSEE(); + /* refcnt of unneeded sv is 2 at this point + (one from newHV, second from SEEN call) */ + SvREFCNT_dec(sv); + SvREFCNT_dec(sv); + /* we need to free RV but preserve value that RV point to */ + sv = SvRV(attached); + SEEN0_NN(sv, 0); + SvRV_set(attached, NULL); + SvREFCNT_dec(attached); + if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) + Safefree(classname); + return sv; + } + CROAK(("STORABLE_attach did not return a %s object", classname)); + } + + /* + * Bless the object and look up the STORABLE_thaw hook. + */ + + BLESS(sv, stash); + + hook = pkg_can(aTHX_ cxt->hook, stash, "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_inc(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 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 */ + + 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; +} + +static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname) { + return retrieve_hook_common(aTHX_ cxt, cname, FALSE); +} + +/* + * retrieve_ref + * + * Retrieve reference to some other scalar. + * Layout is SX_REF , with SX_REF already read. + */ +static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *rv; + SV *sv; + HV *stash; + + TRACEME(("retrieve_ref (#%d)", (int)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); + if (cname) + stash = gv_stashpv(cname, GV_ADD); + else + stash = 0; + SEEN_NN(rv, stash, 0); /* Will return if rv is null */ + sv = retrieve(aTHX_ cxt, 0);/* Retrieve */ + 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); + /*if (cxt->entry && ++cxt->ref_cnt > MAX_REF_CNT) { + CROAK(("Max. recursion depth with nested refs exceeded")); + }*/ + + TRACEME(("ok (retrieve_ref at 0x%" UVxf ")", PTR2UV(rv))); + + return rv; +} + +/* + * retrieve_weakref + * + * Retrieve weak reference to some other scalar. + * Layout is SX_WEAKREF , with SX_WEAKREF already read. + */ +static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *sv; + + TRACEME(("retrieve_weakref (#%d)", (int)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 , 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)", (int)cxt->tagnum)); + + /* + * Same code as retrieve_ref(), duplicated to avoid extra call. + */ + + rv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(rv, stash, 0); /* Will return if rv is null */ + cxt->in_retrieve_overloaded = 1; /* so sv_bless doesn't call S_reset_amagic */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ + cxt->in_retrieve_overloaded = 0; + 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 )", + 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 , with SX_WEAKOVERLOADED already read. + */ +static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *sv; + + TRACEME(("retrieve_weakoverloaded (#%d)", (int)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 , with SX_TIED_ARRAY already read. + */ +static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *tv; + SV *sv; + HV *stash; + + TRACEME(("retrieve_tied_array (#%d)", (int)cxt->tagnum)); + + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } + + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ + if (!sv) + return (SV *) 0; /* Failed */ + + sv_upgrade(tv, SVt_PVAV); + 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 , with SX_TIED_HASH already read. + */ +static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *tv; + SV *sv; + HV *stash; + + TRACEME(("retrieve_tied_hash (#%d)", (int)cxt->tagnum)); + + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } + + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ + 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 , with SX_TIED_SCALAR already read. + */ +static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *tv; + SV *sv, *obj = NULL; + HV *stash; + + TRACEME(("retrieve_tied_scalar (#%d)", (int)cxt->tagnum)); + + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } + + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if rv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ + 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 , with SX_TIED_KEY already read. + */ +static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *tv; + SV *sv; + SV *key; + HV *stash; + + TRACEME(("retrieve_tied_key (#%d)", (int)cxt->tagnum)); + + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } + + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ + if (!sv) + return (SV *) 0; /* Failed */ + + key = retrieve(aTHX_ cxt, 0); /* Retrieve */ + 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 , with SX_TIED_IDX already read. + */ +static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *tv; + SV *sv; + HV *stash; + I32 idx; + + TRACEME(("retrieve_tied_idx (#%d)", (int)cxt->tagnum)); + + if (!(cxt->flags & FLAG_TIE_OK)) { + CROAK(("Tying is disabled.")); + } + + tv = NEWSV(10002, 0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(tv, stash, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ + if (!sv) + return (SV *) 0; /* Failed */ + + RLEN(idx); /* Retrieve */ + + sv_upgrade(tv, SVt_PVMG); + sv_magic(tv, sv, 'p', (char *)NULL, idx); + SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ + + return tv; +} + +/* + * get_lstring + * + * Helper to read a string + */ +static SV *get_lstring(pTHX_ stcxt_t *cxt, UV len, int isutf8, const char *cname) +{ + SV *sv; + HV *stash; + + TRACEME(("get_lstring (#%d), len = %" UVuf, (int)cxt->tagnum, len)); + + /* + * Allocate an empty scalar of the suitable length. + */ + + sv = NEWSV(10002, len); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ + + if (len == 0) { + SvPVCLEAR(sv); + 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 */ + + /* Check for CVE-215-1592 */ + if (cname && len == 13 && strEQc(cname, "CGITempFile") + && strEQc(SvPVX(sv), "mt-config.cgi")) { +#if defined(USE_CPERL) && defined(WARN_SECURITY) + Perl_warn_security(aTHX_ + "Movable-Type CVE-2015-1592 Storable metasploit attack"); +#else + Perl_warn(aTHX_ + "SECURITY: Movable-Type CVE-2015-1592 Storable metasploit attack"); +#endif + } + + if (isutf8) { + TRACEME(("large utf8 string len %" UVuf " '%s'", len, + len >= 2048 ? "" : SvPVX(sv))); +#ifdef HAS_UTF8_SCALARS + SvUTF8_on(sv); +#else + if (cxt->use_bytes < 0) + cxt->use_bytes + = (SvTRUE(get_sv("Storable::drop_utf8", GV_ADD)) + ? 1 : 0); + if (cxt->use_bytes == 0) + UTF8_CROAK(); +#endif + } else { + TRACEME(("large string len %" UVuf " '%s'", len, + len >= 2048 ? "" : SvPVX(sv))); + } + TRACEME(("ok (get_lstring at 0x%" UVxf ")", PTR2UV(sv))); + + return sv; +} + +/* + * retrieve_lscalar + * + * Retrieve defined long (string) scalar. + * + * Layout is SX_LSCALAR , with SX_LSCALAR already read. + * The scalar is "long" in that is larger than LG_SCALAR so it + * was not stored on a single byte, but in 4 bytes. For strings longer than + * 4 byte (>2GB) see retrieve_lobject. + */ +static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname) +{ + U32 len; + RLEN(len); + return get_lstring(aTHX_ cxt, len, 0, cname); +} + +/* + * retrieve_scalar + * + * Retrieve defined short (string) scalar. + * + * Layout is SX_SCALAR , with SX_SCALAR already read. + * The scalar is "short" so is single byte. If it is 0, there + * is no section. + */ +static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname) +{ + int len; + /*SV *sv; + HV *stash;*/ + + GETMARK(len); + TRACEME(("retrieve_scalar (#%d), len = %d", (int)cxt->tagnum, len)); + return get_lstring(aTHX_ cxt, (UV)len, 0, cname); +} + +/* + * 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) +{ + int len; + /*SV *sv;*/ + + TRACEME(("retrieve_utf8str")); + GETMARK(len); + return get_lstring(aTHX_ cxt, (UV)len, 1, cname); +} + +/* + * 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) +{ + U32 len; + + TRACEME(("retrieve_lutf8str")); + + RLEN(len); + return get_lstring(aTHX_ cxt, (UV)len, 1, cname); +} + +/* + * retrieve_vstring + * + * Retrieve a vstring, and then retrieve the stringy scalar following it, + * attaching the vstring to the scalar via magic. + * If we're retrieving a vstring in a perl without vstring magic, croaks. + * + * The vstring layout mirrors an SX_SCALAR string: + * SX_VSTRING with SX_VSTRING already read. + */ +static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname) +{ +#ifdef SvVOK + char s[256]; + int len; + SV *sv; + + GETMARK(len); + TRACEME(("retrieve_vstring (#%d), len = %d", (int)cxt->tagnum, len)); + + READ(s, len); + sv = retrieve(aTHX_ cxt, cname); + if (!sv) + return (SV *) 0; /* Failed */ + sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); + /* 5.10.0 and earlier seem to need this */ + SvRMAGICAL_on(sv); + + TRACEME(("ok (retrieve_vstring at 0x%" UVxf ")", PTR2UV(sv))); + return sv; +#else + VSTRING_CROAK(); + return Nullsv; +#endif +} + +/* + * retrieve_lvstring + * + * Like retrieve_vstring, but for longer vstrings. + */ +static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname) +{ +#ifdef SvVOK + char *s; + I32 len; + SV *sv; + + RLEN(len); + TRACEME(("retrieve_lvstring (#%d), len = %" IVdf, + (int)cxt->tagnum, (IV)len)); + + New(10003, s, len+1, char); + SAFEPVREAD(s, len, s); + + sv = retrieve(aTHX_ cxt, cname); + if (!sv) { + Safefree(s); + return (SV *) 0; /* Failed */ + } + sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); + /* 5.10.0 and earlier seem to need this */ + SvRMAGICAL_on(sv); + + Safefree(s); + + TRACEME(("ok (retrieve_lvstring at 0x%" UVxf ")", PTR2UV(sv))); + return sv; +#else + VSTRING_CROAK(); + return Nullsv; +#endif +} + +/* + * retrieve_integer + * + * Retrieve defined integer. + * Layout is SX_INTEGER , whith SX_INTEGER already read. + */ +static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *sv; + HV *stash; + IV iv; + + TRACEME(("retrieve_integer (#%d)", (int)cxt->tagnum)); + + READ(&iv, sizeof(iv)); + sv = newSViv(iv); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ + + TRACEME(("integer %" IVdf, iv)); + TRACEME(("ok (retrieve_integer at 0x%" UVxf ")", PTR2UV(sv))); + + return sv; +} + +/* + * retrieve_lobject + * + * Retrieve overlong scalar, array or hash. + * Layout is SX_LOBJECT type U64_len ... + */ +static SV *retrieve_lobject(pTHX_ stcxt_t *cxt, const char *cname) +{ + int type; +#ifdef HAS_U64 + UV len; + SV *sv; + int hash_flags = 0; +#endif + + TRACEME(("retrieve_lobject (#%d)", (int)cxt->tagnum)); + + GETMARK(type); + TRACEME(("object type %d", type)); +#ifdef HAS_U64 + + if (type == SX_FLAG_HASH) { + /* we write the flags immediately after the op. I could have + changed the writer, but this may allow someone to recover + data they're already frozen, though such a very large hash + seems unlikely. + */ + GETMARK(hash_flags); + } + else if (type == SX_HOOK) { + return retrieve_hook_common(aTHX_ cxt, cname, TRUE); + } + + READ_U64(len); + TRACEME(("wlen %" UVuf, len)); + switch (type) { + case SX_OBJECT: + { + /* not a large object, just a large index */ + SV **svh = av_fetch(cxt->aseen, len, FALSE); + if (!svh) + CROAK(("Object #%" UVuf " should have been retrieved already", + len)); + sv = *svh; + TRACEME(("had retrieved #%" UVuf " at 0x%" UVxf, len, PTR2UV(sv))); + SvREFCNT_inc(sv); + } + break; + case SX_LSCALAR: + sv = get_lstring(aTHX_ cxt, len, 0, cname); + break; + case SX_LUTF8STR: + sv = get_lstring(aTHX_ cxt, len, 1, cname); + break; + case SX_ARRAY: + sv = get_larray(aTHX_ cxt, len, cname); + break; + /* <5.12 you could store larger hashes, but cannot iterate over them. + So we reject them, it's a bug. */ + case SX_FLAG_HASH: + sv = get_lhash(aTHX_ cxt, len, hash_flags, cname); + break; + case SX_HASH: + sv = get_lhash(aTHX_ cxt, len, 0, cname); + break; + default: + CROAK(("Unexpected type %d in retrieve_lobject\n", type)); + } + + TRACEME(("ok (retrieve_lobject at 0x%" UVxf ")", PTR2UV(sv))); + return sv; +#else + PERL_UNUSED_ARG(cname); + + /* previously this (brokenly) checked the length value and only failed if + the length was over 4G. + Since this op should only occur with objects over 4GB (or 2GB) we can just + reject it. + */ + CROAK(("Invalid large object op for this 32bit system")); +#endif +} + +/* + * retrieve_netint + * + * Retrieve defined integer in network order. + * Layout is SX_NETINT , whith SX_NETINT already read. + */ +static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *sv; + HV *stash; + I32 iv; + + TRACEME(("retrieve_netint (#%d)", (int)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 + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 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 , whith SX_DOUBLE already read. + */ +static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *sv; + HV *stash; + NV nv; + + TRACEME(("retrieve_double (#%d)", (int)cxt->tagnum)); + + READ(&nv, sizeof(nv)); + sv = newSVnv(nv); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 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 , whith SX_BYTE already read. + */ +static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname) +{ + SV *sv; + HV *stash; + int siv; +#ifdef _MSC_VER + /* MSVC 2017 doesn't handle the AIX workaround well */ + int tmp; +#else + signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */ +#endif + + TRACEME(("retrieve_byte (#%d)", (int)cxt->tagnum)); + + GETMARK(siv); + TRACEME(("small integer read as %d", (unsigned char) siv)); + tmp = (unsigned char) siv - 128; + sv = newSViv(tmp); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 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; + HV *stash; + + TRACEME(("retrieve_undef")); + + sv = newSV(0); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 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; + HV *stash; + + 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 == UNSET_NTAG_T) { + cxt->where_is_undef = cxt->tagnum; + } + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 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; + HV *stash; + + TRACEME(("retrieve_sv_yes")); + + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 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; + HV *stash; + + TRACEME(("retrieve_sv_no")); + + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 1); + return sv; +} + +/* + * retrieve_svundef_elem + * + * Return &PL_sv_placeholder, representing &PL_sv_undef in an array. This + * is a bit of a hack, but we already use SX_SV_UNDEF to mean a nonexistent + * element, for historical reasons. + */ +static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname) +{ + TRACEME(("retrieve_svundef_elem")); + + /* SEEN reads the contents of its SV argument, which we are not + supposed to do with &PL_sv_placeholder. */ + SEEN_NN(&PL_sv_undef, cname, 1); + + return &PL_sv_placeholder; +} + +/* + * retrieve_array + * + * Retrieve a whole array. + * Layout is SX_ARRAY followed by each item, in increasing index order. + * Each item is stored as . + * + * When we come here, SX_ARRAY has been read already. + */ +static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) +{ + I32 len, i; + AV *av; + SV *sv; + HV *stash; + bool seen_null = FALSE; + + TRACEME(("retrieve_array (#%d)", (int)cxt->tagnum)); + + /* + * Read length, and allocate array, then pre-extend it. + */ + + RLEN(len); + TRACEME(("size = %d", (int)len)); + av = newAV(); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(av, stash, 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", (int)i)); + sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ + if (!sv) + return (SV *) 0; + if (sv == &PL_sv_undef) { + seen_null = TRUE; + continue; + } + if (sv == &PL_sv_placeholder) + sv = &PL_sv_undef; + if (av_store(av, i, sv) == 0) + return (SV *) 0; + } + if (seen_null) av_fill(av, len-1); + + TRACEME(("ok (retrieve_array at 0x%" UVxf ")", PTR2UV(av))); + + return (SV *) av; +} + +#ifdef HAS_U64 + +/* internal method with len already read */ + +static SV *get_larray(pTHX_ stcxt_t *cxt, UV len, const char *cname) +{ + UV i; + AV *av; + SV *sv; + HV *stash; + bool seen_null = FALSE; + + TRACEME(("get_larray (#%d) %lu", (int)cxt->tagnum, (unsigned long)len)); + + /* + * allocate array, then pre-extend it. + */ + + av = newAV(); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(av, stash, 0); /* Will return if array not allocated nicely */ + assert(len); + av_extend(av, len); + + /* + * Now get each item in turn... + */ + + for (i = 0; i < len; i++) { + TRACEME(("(#%d) item", (int)i)); + sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ + if (!sv) + return (SV *) 0; + if (sv == &PL_sv_undef) { + seen_null = TRUE; + continue; + } + if (sv == &PL_sv_placeholder) + sv = &PL_sv_undef; + if (av_store(av, i, sv) == 0) + return (SV *) 0; + } + if (seen_null) av_fill(av, len-1); + + TRACEME(("ok (get_larray at 0x%" UVxf ")", PTR2UV(av))); + + return (SV *) av; +} + +/* + * get_lhash + * + * Retrieve a overlong hash table. + * is already read. What follows is each key/value pair, in random order. + * Keys are stored as , the section being omitted + * if length is 0. + * Values are stored as . + * + */ +static SV *get_lhash(pTHX_ stcxt_t *cxt, UV len, int hash_flags, const char *cname) +{ + UV size; + UV i; + HV *hv; + SV *sv; + HV *stash; + + TRACEME(("get_lhash (#%d)", (int)cxt->tagnum)); + +#ifdef HAS_RESTRICTED_HASHES + PERL_UNUSED_ARG(hash_flags); +#else + if (hash_flags & SHV_RESTRICTED) { + if (cxt->derestrict < 0) + cxt->derestrict = (SvTRUE + (get_sv("Storable::downgrade_restricted", GV_ADD)) + ? 1 : 0); + if (cxt->derestrict == 0) + RESTRICTED_HASH_CROAK(); + } +#endif + + TRACEME(("size = %lu", (unsigned long)len)); + hv = newHV(); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */ + if (len == 0) + return (SV *) hv; /* No data follow if table empty */ + TRACEME(("split %lu", (unsigned long)len+1)); + hv_ksplit(hv, len+1); /* 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", (int)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'", (int)i, kbuf)); + + /* + * Enter key/value pair into hash table. + */ + + if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) + return (SV *) 0; + } + + TRACEME(("ok (get_lhash at 0x%" UVxf ")", PTR2UV(hv))); + return (SV *) hv; +} +#endif + +/* + * retrieve_hash + * + * Retrieve a whole hash table. + * Layout is SX_HASH followed by each key/value pair, in random order. + * Keys are stored as , the section being omitted + * if length is 0. + * Values are stored as . + * + * 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; + HV *stash; + + TRACEME(("retrieve_hash (#%d)", (int)cxt->tagnum)); + + /* + * Read length, allocate table. + */ + + RLEN(len); + TRACEME(("size = %d", (int)len)); + hv = newHV(); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */ + if (len == 0) + return (SV *) hv; /* No data follow if table empty */ + TRACEME(("split %d", (int)len+1)); + hv_ksplit(hv, len+1); /* 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", (int)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'", (int)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 followed by each key/value pair, in random order. + * Keys are stored as , the section being omitted + * if length is 0. + * Values are stored as . + * + * 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; + HV *stash; + int hash_flags; + + GETMARK(hash_flags); + TRACEME(("retrieve_flag_hash (#%d)", (int)cxt->tagnum)); + /* + * Read length, allocate table. + */ + +#ifndef HAS_RESTRICTED_HASHES + if (hash_flags & SHV_RESTRICTED) { + if (cxt->derestrict < 0) + cxt->derestrict = (SvTRUE + (get_sv("Storable::downgrade_restricted", GV_ADD)) + ? 1 : 0); + if (cxt->derestrict == 0) + RESTRICTED_HASH_CROAK(); + } +#endif + + RLEN(len); + TRACEME(("size = %d, flags = %d", (int)len, hash_flags)); + hv = newHV(); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */ + if (len == 0) + return (SV *) hv; /* No data follow if table empty */ + TRACEME(("split %d", (int)len+1)); + hv_ksplit(hv, len+1); /* 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", (int)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", (int)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(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", (int)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; + I32 type, count; + IV tagnum; + SV *cv; + SV *sv, *text, *sub, *errsv; + HV *stash; + + TRACEME(("retrieve_code (#%d)", (int)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); + stash = cname ? gv_stashpv(cname, GV_ADD) : 0; + SEEN_NN(sv, stash, 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; + case SX_UTF8STR: + text = retrieve_utf8str(aTHX_ cxt, cname); + break; + case SX_LUTF8STR: + text = retrieve_lutf8str(aTHX_ cxt, cname); + break; + default: + CROAK(("Unexpected type %d in retrieve_code\n", (int)type)); + } + + if (!text) { + CROAK(("Unable to retrieve code\n")); + } + + /* + * prepend "sub " to the source + */ + + sub = newSVpvs("sub "); + if (SvUTF8(text)) + SvUTF8_on(sub); + 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 = 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 + (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; + + errsv = get_sv("@", GV_ADD); + SvPVCLEAR(errsv); /* clear $@ */ + if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) { + PUSHMARK(sp); + XPUSHs(sv_2mortal(newSVsv(sub))); + PUTBACK; + count = call_sv(cxt->eval, G_SCALAR); + if (count != 1) + CROAK(("Unexpected return value from $Storable::Eval callback\n")); + } else { + eval_sv(sub, G_SCALAR); + } + SPAGAIN; + cv = POPs; + PUTBACK; + + if (SvTRUE(errsv)) { + CROAK(("code %s caused an error: %s", + SvPV_nolen(sub), SvPV_nolen(errsv))); + } + + 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 +} + +static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) { +#if PERL_VERSION >= 8 + int op_flags; + U32 re_len; + STRLEN flags_len; + SV *re; + SV *flags; + SV *re_ref; + SV *sv; + dSP; + I32 count; + + PERL_UNUSED_ARG(cname); + + ENTER; + SAVETMPS; + + GETMARK(op_flags); + if (op_flags & SHR_U32_RE_LEN) { + RLEN(re_len); + } + else + GETMARK(re_len); + + re = sv_2mortal(NEWSV(10002, re_len ? re_len : 1)); + READ(SvPVX(re), re_len); + SvCUR_set(re, re_len); + *SvEND(re) = '\0'; + SvPOK_only(re); + + GETMARK(flags_len); + flags = sv_2mortal(NEWSV(10002, flags_len ? flags_len : 1)); + READ(SvPVX(flags), flags_len); + SvCUR_set(flags, flags_len); + *SvEND(flags) = '\0'; + SvPOK_only(flags); + + PUSHMARK(SP); + + XPUSHs(re); + XPUSHs(flags); + + PUTBACK; + + count = call_pv("Storable::_make_re", G_SCALAR); + + SPAGAIN; + + if (count != 1) + CROAK(("Bad count %d calling _make_re", count)); + + re_ref = POPs; + + PUTBACK; + + if (!SvROK(re_ref)) + CROAK(("_make_re didn't return a reference")); + + sv = SvRV(re_ref); + SvREFCNT_inc(sv); + + FREETMPS; + LEAVE; + + return sv; +#else + CROAK(("retrieve_regexp does not work with 5.6 or earlier")); +#endif +} + +/* + * old_retrieve_array + * + * Retrieve a whole array in pre-0.6 binary format. + * + * Layout is SX_ARRAY followed by each item, in increasing index order. + * Each item is stored as SX_ITEM 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; + + PERL_UNUSED_ARG(cname); + TRACEME(("old_retrieve_array (#%d)", (int)cxt->tagnum)); + + /* + * Read length, and allocate array, then pre-extend it. + */ + + RLEN(len); + TRACEME(("size = %d", (int)len)); + av = newAV(); + SEEN0_NN(av, 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", (int)i)); + continue; /* av_extend() already filled us with undef */ + } + if (c != SX_ITEM) + (void) retrieve_other(aTHX_ cxt, 0);/* Will croak out */ + TRACEME(("(#%d) item", (int)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 followed by each key/value pair, in random order. + * Keys are stored as SX_KEY , the section being omitted + * if length is 0. + * Values are stored as SX_VALUE 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 */ + + PERL_UNUSED_ARG(cname); + TRACEME(("old_retrieve_hash (#%d)", (int)cxt->tagnum)); + + /* + * Read length, allocate table. + */ + + RLEN(len); + TRACEME(("size = %d", (int)len)); + hv = newHV(); + SEEN0_NN(hv, 0); /* Will return if table not allocated properly */ + if (len == 0) + return (SV *) hv; /* No data follow if table empty */ + TRACEME(("split %d", (int)len+1)); + hv_ksplit(hv, len+1); /* 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", (int)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", (int)i)); + sv = retrieve(aTHX_ cxt, 0); + if (!sv) + return (SV *) 0; + } else + (void) retrieve_other(aTHX_ cxt, 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_ cxt, 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'", (int)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(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 convenient. */ + 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(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 explicitly tags them, we must keep track of the correspondence + * 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, (int)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); +#ifndef HAS_U64 + /* A 32-bit system can't have over 2**31 objects anyway */ + if (tag < 0) + CROAK(("Object #%" IVdf " out of range", (IV)tag)); +#endif + /* Older versions of Storable on with 64-bit support on 64-bit + systems can produce values above the 2G boundary (or wrapped above + the 4G boundary, which we can't do much about), treat those as + unsigned. + This same commit stores tag ids over the 2G boundary as long tags + since older Storables will mis-handle them as short tags. + */ + svh = av_fetch(cxt->aseen, (U32)tag, FALSE); + if (!svh) + CROAK(("Object #%" IVdf " should have been retrieved already", + (IV) tag)); + sv = *svh; + TRACEME(("had retrieved #%d at 0x%" UVxf, (int)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_LAST && cxt->ver_minor > STORABLE_BIN_MINOR) { + if (cxt->accept_future_minor < 0) + cxt->accept_future_minor + = (SvTRUE(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_LAST - 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 for short classnames. + * SX_LG_CLASS 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; + HV* stash; + 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 */ + stash = gv_stashpvn(kbuf, len, GV_ADD); + BLESS(sv, stash); + } + } + + TRACEME(("ok (retrieved 0x%" UVxf ", refcnt=%d, %s)", PTR2UV(sv), + (int)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, + int flags) +{ + dSTCXT; + SV *sv; + int is_tainted; /* Is input source tainted? */ + int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */ + + TRACEMED(("do_retrieve (optype = 0x%x, flags=0x%x)", + (unsigned)optype, (unsigned)flags)); + + optype |= ST_RETRIEVE; + cxt->flags = flags; + + /* + * 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[(int)SX_LAST] == retrieve_other, + ("SX_LAST entry correctly initialized in old dispatch table")); + ASSERT(sv_retrieve[(int)SX_LAST] == retrieve_other, + ("SX_LAST entry correctly initialized in new dispatch table")); + + /* + * Workaround for CROAK leak: if they enter with a "dirty" context, + * free up memory for them now. + */ + + assert(cxt); + 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->flags = flags; + } + INIT_TRACEME; + + 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) { + TRACEMED(("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 + } + + TRACEMED(("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; + TRACEMED(("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 implicitly 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); + TRACEMED(("restored overloading on root reference")); + } + TRACEMED(("ended do_retrieve() with an object")); + return rv; + } + + TRACEMED(("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, IV flag) +{ + TRACEMED(("pretrieve")); + return do_retrieve(aTHX_ f, Nullsv, 0, (int)flag); +} + +/* + * mretrieve + * + * Retrieve data held in scalar and return the root object, undef on error. + */ +static SV *mretrieve(pTHX_ SV *sv, IV flag) +{ + TRACEMED(("mretrieve")); + return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0, (int)flag); +} + +/*** + *** 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; + STRLEN size; + stcxt_t *real_context; + SV *out; + + TRACEMED(("dclone")); + + /* + * Workaround for CROAK leak: if they enter with a "dirty" context, + * free up memory for them now. + */ + + assert(cxt); + 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 + ) && (SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) == + (SVs_GMG|SVs_SMG|SVs_RMG) && + 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); + ASSERT(!cxt->s_dirty, ("clean context")); + ASSERT(!cxt->entry, ("entry will not cause new context allocation")); + + size = MBUF_SIZE(); + TRACEME(("dclone stored %ld bytes", (long)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, FLAG_BLESS_OK | FLAG_TIE_OK); + + TRACEMED(("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 */ + +static int +storable_free(pTHX_ SV *sv, MAGIC* mg) { + stcxt_t *cxt = (stcxt_t *)SvPVX(sv); + + PERL_UNUSED_ARG(mg); + if (kbuf) + Safefree(kbuf); + if (!cxt->membuf_ro && mbase) + Safefree(mbase); + if (cxt->membuf_ro && (cxt->msaved).arena) + Safefree((cxt->msaved).arena); + return 0; +} + +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); + +# pstore +# +# Store the transitive data closure of given object to disk. +# Returns undef on error, a true value otherwise. + +# net_pstore +# +# Same as pstore(), but network order is used for integers and doubles are +# emitted as strings. + +SV * +pstore(f,obj) + OutputStream f + SV* obj +ALIAS: + net_pstore = 1 +PPCODE: + RETVAL = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef; + /* do_store() can reallocate the stack, so need a sequence point to ensure + that ST(0) knows about it. Hence using two statements. */ + ST(0) = RETVAL; + XSRETURN(1); + +# mstore +# +# Store the transitive data closure of given object to memory. +# Returns undef on error, a scalar value containing the data otherwise. + +# net_mstore +# +# Same as mstore(), but network order is used for integers and doubles are +# emitted as strings. + +SV * +mstore(obj) + SV* obj +ALIAS: + net_mstore = 1 +CODE: + RETVAL = &PL_sv_undef; + if (!do_store(aTHX_ (PerlIO*) 0, obj, 0, ix, &RETVAL)) + RETVAL = &PL_sv_undef; +OUTPUT: + RETVAL + +SV * +pretrieve(f, flag = 6) + InputStream f + IV flag +CODE: + RETVAL = pretrieve(aTHX_ f, flag); +OUTPUT: + RETVAL + +SV * +mretrieve(sv, flag = 6) + SV* sv + IV flag +CODE: + RETVAL = mretrieve(aTHX_ sv, flag); +OUTPUT: + RETVAL + +SV * +dclone(sv) + SV* sv +CODE: + RETVAL = dclone(aTHX_ sv); +OUTPUT: + RETVAL + +void +last_op_in_netorder() +ALIAS: + is_storing = ST_STORE + is_retrieving = ST_RETRIEVE +PREINIT: + bool result; +CODE: + if (ix) { + dSTCXT; + assert(cxt); + result = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE; + } else { + result = !!last_op_in_netorder(aTHX); + } + ST(0) = boolSV(result); + + +IV +stack_depth() +CODE: + RETVAL = SvIV(get_sv("Storable::recursion_limit", GV_ADD)); +OUTPUT: + RETVAL + +IV +stack_depth_hash() +CODE: + RETVAL = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD)); +OUTPUT: + RETVAL diff --git a/__Storable__.pm b/__Storable__.pm new file mode 100644 index 0000000..48e6f45 --- /dev/null +++ b/__Storable__.pm @@ -0,0 +1,1430 @@ +# +# Copyright (c) 1995-2001, Raphael Manfredi +# Copyright (c) 2002-2014 by the Perl 5 Porters +# Copyright (c) 2015-2016 cPanel Inc +# Copyright (c) 2017 Reini Urban +# +# You may redistribute only under the same terms as Perl 5, as specified +# in the README file that comes with the distribution. +# + +require XSLoader; +require Exporter; +package Storable; + +our @ISA = qw(Exporter); +our @EXPORT = qw(store retrieve); +our @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 + BLESS_OK TIE_OK FLAGS_COMPAT + stack_depth stack_depth_hash +); + +our ($canonical, $forgive_me); + +our $VERSION = '3.11'; + +our $recursion_limit; +our $recursion_limit_hash; + +do "Storable/Limit.pm"; + +$recursion_limit = 512 + unless defined $recursion_limit; +$recursion_limit_hash = 256 + unless defined $recursion_limit_hash; + +BEGIN { + if (eval { + local $SIG{__DIE__}; + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + require Log::Agent; + 1; + }) { + Log::Agent->import; + } + # + # Use of Log::Agent is optional. If it hasn't imported these subs then + # provide a fallback implementation. + # + unless ($Storable::{logcroak} && *{$Storable::{logcroak}}{CODE}) { + require Carp; + *logcroak = sub { + Carp::croak(@_); + }; + } + unless ($Storable::{logcarp} && *{$Storable::{logcarp}}{CODE}) { + require Carp; + *logcarp = sub { + Carp::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(); +} + +sub BLESS_OK () { 2 } +sub TIE_OK () { 4 } +sub FLAGS_COMPAT () { BLESS_OK | TIE_OK } + +# By default restricted hashes are downgraded on earlier perls. + +$Storable::flags = FLAGS_COMPAT; +$Storable::downgrade_restricted = 1; +$Storable::accept_future_minor = 1; + +XSLoader::load('Storable'); + +# +# Determine whether locking is possible, but only when needed. +# + +sub CAN_FLOCK; # TEMPLATE - replaced by Storable.pm.PL + +sub show_file_magic { + print <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 { + require IO::File; + + my $file = shift; + my $fh = IO::File->new; + 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 { + $buf =~ s/(.)//s; + my $major = (ord $1) >> 1; + return undef if $major > 4; # sanity (assuming we never go that high) + $info{major} = $major; + $net_order = (ord $1) & 0x01; + if ($major > 1) { + return undef unless $buf =~ s/(.)//s; + my $minor = ord $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 $buf =~ s/(.)//s; + my $len = ord $1; + return undef unless length($buf) >= $len; + return undef unless $len == 4 || $len == 8; # sanity + @info{qw(byteorder intsize longsize ptrsize)} + = unpack "a${len}CCC", $buf; + (substr $buf, 0, $len + 3) = ''; + if ($info{version_nv} >= 2.002) { + return undef unless $buf =~ s/(.)//s; + $info{nvsize} = ord $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 will return true on success, so the or short-circuits, the () + # expression is true, and for that case the block will only be entered + # if $@ is true (ie eval failed) + # if close fails, it returns false, $ret is altered, *that* is (also) + # false, so the () expression is false, !() is true, and the block is + # entered. + if (!(close(FILE) or undef $ret) || $@) { + unlink($file) or warn "Can't unlink $file: $!\n"; + } + if ($@) { + $@ =~ s/\.?\n$/,/ unless ref $@; + logcroak $@; + } + $@ = $da; + return $ret; +} + +# +# 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; +} + +# +# freeze +# +# Store object 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) }; + if ($@) { + $@ =~ s/\.?\n$/,/ unless ref $@; + logcroak $@; + } + $@ = $da; + return $ret ? $ret : undef; +} + +# +# retrieve +# +# Retrieve object hierarchy from disk, returning a reference to the root +# object of that tree. +# +# retrieve(file, flags) +# flags include by default BLESS_OK=2 | TIE_OK=4 +# with flags=0 or the global $Storable::flags set to 0, no resulting object +# will be blessed nor tied. +# +sub retrieve { + _retrieve(shift, 0, @_); +} + +# +# lock_retrieve +# +# Same as retrieve, but with advisory locking. +# +sub lock_retrieve { + _retrieve(shift, 1, @_); +} + +# Internal retrieve routine +sub _retrieve { + my ($file, $use_locking, $flags) = @_; + $flags = $Storable::flags unless defined $flags; + my $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, $flags) }; # Call C routine + close($FILE); + if ($@) { + $@ =~ s/\.?\n$/,/ unless ref $@; + logcroak $@; + } + $@ = $da; + return $self; +} + +# +# fd_retrieve +# +# Same as retrieve, but perform from an already opened file descriptor instead. +# +sub fd_retrieve { + my ($file, $flags) = @_; + $flags = $Storable::flags unless defined $flags; + 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, $flags) }; # Call C routine + if ($@) { + $@ =~ s/\.?\n$/,/ unless ref $@; + logcroak $@; + } + $@ = $da; + return $self; +} + +sub retrieve_fd { &fd_retrieve } # Backward compatibility + +# +# thaw +# +# Recreate objects in memory from an existing frozen image created +# by freeze. If the frozen image passed is undef, return undef. +# +# thaw(frozen_obj, flags) +# flags include by default BLESS_OK=2 | TIE_OK=4 +# with flags=0 or the global $Storable::flags set to 0, no resulting object +# will be blessed nor tied. +# +sub thaw { + my ($frozen, $flags) = @_; + $flags = $Storable::flags unless defined $flags; + return undef unless defined $frozen; + my $self; + my $da = $@; # Could be from exception handler + eval { $self = mretrieve($frozen, $flags) };# Call C routine + if ($@) { + $@ =~ s/\.?\n$/,/ unless ref $@; + logcroak $@; + } + $@ = $da; + return $self; +} + +# +# _make_re($re, $flags) +# +# Internal function used to thaw a regular expression. +# + +my $re_flags; +BEGIN { + if ($] < 5.010) { + $re_flags = qr/\A[imsx]*\z/; + } + elsif ($] < 5.014) { + $re_flags = qr/\A[msixp]*\z/; + } + elsif ($] < 5.022) { + $re_flags = qr/\A[msixpdual]*\z/; + } + else { + $re_flags = qr/\A[msixpdualn]*\z/; + } +} + +sub _make_re { + my ($re, $flags) = @_; + + $flags =~ $re_flags + or die "regexp flags invalid"; + + my $qr = eval "qr/\$re/$flags"; + die $@ if $@; + + $qr; +} + +if ($] < 5.012) { + eval <<'EOS' +sub _regexp_pattern { + my $re = "" . shift; + $re =~ /\A\(\?([xism]*)(?:-[xism]*)?:(.*)\)\z/s + or die "Cannot parse regexp /$re/"; + return ($2, $1); +} +1 +EOS + or die "Cannot define _regexp_pattern: $@"; +} + +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 with +a reference to the object to be stored, along with the file name where +the image should be written. + +The routine returns C for I/O problems or other internal error, +a true value otherwise. Serious errors are propagated as a C exception. + +To retrieve data stored to disk, use C with a file name. +The objects stored into that file are recreated into memory for you, +and a I to the root object is returned. In case an I/O error +occurs while reading, C is returned instead. Other serious +errors are propagated via C. + +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 routine, and retrieve +from a file via C. 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 prefix for I, +as in C and C. 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, objects are retrieved in sequence, one +object (i.e. one recursive tree) per associated C. + +If you're more from the object-oriented camp, you can inherit from +Storable and directly store your objects by invoking C 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 and C. +If you wish to send out the frozen scalar to another machine, use +C 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 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 and C routine are equivalent to +C and C, except that they get an exclusive lock on +the file before writing. Likewise, C does the same +as C, 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 and C. If one side of +your application uses C whilst the other uses C, +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 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. 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, 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. See +below for an example using a L 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 Cing 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. +To change this behaviour so that Storable deserializes utf8 encoded +values as the string of bytes (effectively dropping the I flag) +set C<$Storable::drop_utf8> to some C 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 instead, set +C<$Storable::downgrade_restricted> to a C value. To restore +the default set it back to some C value. + +The cperl PERL_PERTURB_KEYS_TOP hash strategy has a known problem with +restricted hashes. + +=item huge objects + +On 64bit systems some data structures may exceed the 2G (i.e. I32_MAX) +limit. On 32bit systems also strings between I32 and U32 (2G-4G). +Since Storable 3.00 (not in perl5 core) we are able to store and +retrieve these objects, even if perl5 itself is not able to handle +them. These are strings longer then 4G, arrays with more then 2G +elements and hashes with more then 2G elements. cperl forbids hashes +with more than 2G elements, but this fail in cperl then. perl5 itself +at least until 5.26 allows it, but cannot iterate over them. +Note that creating those objects might cause out of memory +exceptions by the operating system before perl has a chance to abort. + +=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 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 and C). +Use eval {} to trap those exceptions. + +When Storable croaks, it tries to report the error via the C +routine from the C package, if it is available. + +Normal errors are reported by having store() or retrieve() return C. +Such errors are usually I/O errors (or truncated stream errors at retrieval). + +When Storable throws the "Max. recursion depth with nested structures +exceeded" error we are already out of stack space. Unfortunately on +some earlier perl versions cleaning up a recursive data structure +recurses into the free calls, which will lead to stack overflows in +the cleanup. This data structure is not properly cleaned up then, it +will only be destroyed during global destruction. + +=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 I, I + +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 is the object to serialize, I 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 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 I, I, I, ... + +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 as an alternate creation routine. + +This means the hook can be inherited like any other method, and that +I is your blessed reference for this particular instance. + +The other arguments should look familiar if you know C: +I is true when we're part of a deep clone operation, I +is the serialized string you returned to the engine in C, +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 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 +warned you. + +It is up to you to use this information to populate I the way you want. + +Returned value: none. + +=item C I, I, I + +While C and C 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 method provides a solution for these +shared objects. Instead of C --E C, +you implement C --E C instead. + +Arguments: I is the class we are attaching to, I is a flag +indicating whether we're in a dclone() or a regular de-serialization via +thaw(), and I 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, the +C method cannot return any references, and C +will throw an error if C tries to return references. + +All information required to "attach" back to the shared resource object +B be contained B in the C return string. +Otherwise, C behaves as normal for C +classes. + +Because C 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 + +=back + +=head2 Predicates + +Predicates are not exportable. They must be called by explicitly prefixing +them with the Storable package name. + +=over 4 + +=item C + +The C 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 + +Returns true if within a store operation (via STORABLE_freeze hook). + +=item C + +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 * + +Since Storable 3.05 we probe for the stack recursion limit for references, +arrays and hashes to a maximal depth of ~1200-35000, otherwise we might +fall into a stack-overflow. On JSON::XS this limit is 512 btw. With +references not immediately referencing each other there's no such +limit yet, so you might fall into such a stack-overflow segfault. + +This probing and the checks performed have some limitations: + +=over + +=item * + +the stack size at build time might be different at run time, eg. the +stack size may have been modified with ulimit(1). If it's larger at +run time Storable may fail the freeze() or thaw() unnecessarily. + +=item * + +the stack size might be different in a thread. + +=item * + +array and hash recursion limits are checked separately against the +same recursion depth, a frozen structure with a large sequence of +nested arrays within many nested hashes may exhaust the processor +stack without triggering Storable's recursion protection. + +=back + +You can control the maximum array and hash recursion depths by +modifying C<$Storable::recursion_limit> and +C<$Storable::recursion_limit_hash> respectively. Either can be set to +C<-1> to prevent any depth checks, though this isn't recommended. + +=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. + +=item * + +The maximal stack recursion limit for your system is returned by +C and C. The hash limit is usually +half the size of the array and ref limit, as the Perl hash API is not optimal. + +=back + +That's why C 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 hook could return: + + ("something", $self->{B}) + +and the B part would be serialized by the engine. In C, 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, which recognizes data files based on +their contents (usually their first few bytes). For this to work, +a certain file called F needs to taught about the I +of the data. Where that configuration file lives depends on the UNIX +flavour; often it's something like F or +F. Your system administrator needs to do the updating of +the F file. The necessary signature information is output to +STDOUT by invoking Storable::show_file_magic(). Note that the GNU +implementation of the C 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. If +the file does not exist or is unreadable then croak. + +The hash returned has the following elements: + +=over + +=item C + +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 + +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 returns a comparable +number that represents the highest file version number that this +version of Storable fully supports (but see discussion of +C<$Storable::accept_future_minor> above). The constant +C function returns what file version +is written and might be less than C in some +configurations. + +=item C, C + +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 + +The is the number of bytes that the Storable header occupies. + +=item C + +This is TRUE if the image store data in network order. This means +that it was created with nstore() or similar. + +=item C + +This is only present when C 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, C, C, C + +These are only present when C 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 element is only present for file format v2.2 and +higher. + +=item C + +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 is returned. + +The hash has the same structure as the one returned by +Storable::file_magic(). The C element is true if the image is a +file image. + +If the $must_be_file argument is provided and is TRUE, then return +C 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 SECURITY WARNING + +B + +Some features of Storable can lead to security vulnerabilities if you +accept Storable documents from untrusted sources with the default +flags. Most obviously, the optional (off by default) CODE reference +serialization feature allows transfer of code to the deserializing +process. Furthermore, any serialized object will cause Storable to +helpfully load the module corresponding to the class of the object in +the deserializing module. For manipulated module names, this can load +almost arbitrary code. Finally, the deserialized object's destructors +will be invoked when the objects get destroyed in the deserializing +process. Maliciously crafted Storable documents may put such objects +in the value of a hash key that is overridden by another key/value +pair in the same hash, thus causing immediate destructor execution. + +To disable blessing objects while thawing/retrieving remove the flag +C = 2 from C<$Storable::flags> or set the 2nd argument for +thaw/retrieve to 0. + +To disable tieing data while thawing/retrieving remove the flag C += 4 from C<$Storable::flags> or set the 2nd argument for thaw/retrieve +to 0. + +With the default setting of C<$Storable::flags> = 6, creating or destroying +random objects, even renamed objects can be controlled by an attacker. +See CVE-2015-1592 and its metasploit module. + +If your application requires accepting data from untrusted sources, +you are best off with a less powerful and more-likely safe +serialization format and implementation. If your data is sufficiently +simple, Cpanel::JSON::XS, Data::MessagePack or Serial are the best +choices and offers maximum interoperability, but note that Serial is +unsafe by default. + +=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 and C 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 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 REGULAR EXPRESSIONS + +Storable now has experimental support for storing regular expressions, +but there are significant limitations: + +=over + +=item * + +perl 5.8 or later is required. + +=item * + +regular expressions with code blocks, ie C or C will throw an exception when thawed. + +=item * + +regular expression syntax and flags have changed over the history of +perl, so a regular expression that you freeze in one version of perl +may fail to thaw or behave differently in another version of perl. + +=item * + +depending on the version of perl, regular expressions can change in +behaviour depending on the context, but later perls will bake that +behaviour into the regexp. + +=back + +Storable will throw an exception if a frozen regular expression cannot +be thawed. + +=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 if they run into such references +unless you set C<$Storable::forgive_me> to some C value. In that +case, the fatal message is converted to 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 is a blunt tool. There is no facility either to +return B strings as utf8 sequences, or to attempt to convert utf8 +data back to 8 bit and C 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 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. If you have such data then 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 + Ulrich Pfeifer + Benjamin A. Holzman + Andrew Ford + Gisle Aas + Jeff Gresham + Murray Nesbitt + Marc Lehmann + Justin Banks + Jarkko Hietaniemi (AGAIN, as perl 5.7.0 Pumpkin!) + Salvador Ortiz Garcia + Dominic Dunlop + Erik Haugan + Benjamin A. Holzman + Reini Urban + Todd Rinaldo + Aaron Crane + +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. Benjamin Holzman added a performance +improvement for overloaded classes; thanks to Grant Street Group for footing +the bill. +Reini Urban took over maintainance from p5p, and added security fixes +and huge object support. + +=head1 AUTHOR + +Storable was written by Raphael Manfredi +FRaphael_Manfredi@pobox.comE> +Maintenance is now done by cperl L + +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. + +=cut diff --git a/hints/gnukfreebsd.pl b/hints/gnukfreebsd.pl new file mode 100644 index 0000000..db63567 --- /dev/null +++ b/hints/gnukfreebsd.pl @@ -0,0 +1 @@ +do './hints/linux.pl' or die $@; diff --git a/hints/gnuknetbsd.pl b/hints/gnuknetbsd.pl new file mode 100644 index 0000000..db63567 --- /dev/null +++ b/hints/gnuknetbsd.pl @@ -0,0 +1 @@ +do './hints/linux.pl' or die $@; diff --git a/hints/hpux.pl b/hints/hpux.pl new file mode 100644 index 0000000..959d6fe --- /dev/null +++ b/hints/hpux.pl @@ -0,0 +1,10 @@ +# 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/hints/linux.pl b/hints/linux.pl new file mode 100644 index 0000000..f6cc0fa --- /dev/null +++ b/hints/linux.pl @@ -0,0 +1,16 @@ +# 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} and !$Config{usethreads}) { + my $optimize = $Config{optimize}; + # works fine with gcc 4 or clang + if ($optimize =~ s/(^| )-O[3-9]( |$)/$1-O2$2/ and $Config{gccversion} =~ /^[23]\./) { + $self->{OPTIMIZE} = $optimize; + } +} + diff --git a/ppport.h b/ppport.h new file mode 100644 index 0000000..a585989 --- /dev/null +++ b/ppport.h @@ -0,0 +1,8214 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.40 + + Automatically created by Devel::PPPort running under perl 5.028000. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.40 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --strip strip all script and doc functionality + from ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.20. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F. + +=head2 --patch=I + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. Note that this does not +automagically add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C or a C program to be installed. + +=head2 --diff=I + +Manually set the diff program and options to use. The default +is to use C, when installed, and output unified +context diffs. + +=head2 --compat-version=I + +Tell F to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F. +This reduces the size of F dramatically and may be useful +if you want to include F in smaller modules without +increasing their distribution size too much. + +The stripped F will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints or warnings for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I + +Show portability information for API elements matching I. +If I is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C prefix is deprecated. Also, +some API functions used to have a C prefix. Using this form is +also deprecated. You can safely use the supported API, as F +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions or variables that were not present in +earlier versions of Perl, and that can't be provided using a macro, you +have to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F. + +These functions or variables will be marked C in the list shown +by C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions or variables, you want either C or global +variants. + +For a C function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + SvRX() NEED_SvRX NEED_SvRX_GLOBAL + caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL + croak_xs_usage() NEED_croak_xs_usage NEED_croak_xs_usage_GLOBAL + die_sv() NEED_die_sv NEED_die_sv_GLOBAL + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + gv_fetchpvn_flags() NEED_gv_fetchpvn_flags NEED_gv_fetchpvn_flags_GLOBAL + load_module() NEED_load_module NEED_load_module_GLOBAL + mess() NEED_mess NEED_mess_GLOBAL + mess_nocontext() NEED_mess_nocontext NEED_mess_nocontext_GLOBAL + mess_sv() NEED_mess_sv NEED_mess_sv_GLOBAL + mg_findext() NEED_mg_findext NEED_mg_findext_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + sv_unmagicext() NEED_sv_unmagicext NEED_sv_unmagicext_GLOBAL + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vmess() NEED_vmess NEED_vmess_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables using the C +macro. Just C<#define> the macro before including C: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C. + +=back + +The good thing is that most of the above can be checked by running +F on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F is causing failure during +the compilation of this module, please check if newer versions +of either this module or C are available on CPAN +before sending a bug report. + +If F was generated using the latest version of +C and is causing failure of this module, please +send a bug report to L. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L. + +=cut + +use strict; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.40; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +ASCII_TO_NEED||5.007001|n +AvFILLp|5.004050||p +AvFILL||| +BhkDISABLE||5.024000| +BhkENABLE||5.024000| +BhkENTRY_set||5.024000| +BhkENTRY||| +BhkFLAGS||| +CALL_BLOCK_HOOKS||| +CLASS|||n +CPERLscope|5.005000||p +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +C_ARRAY_END|5.013002||p +C_ARRAY_LENGTH|5.008001||p +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002|5.004050|p +Copy||| +CvPADLIST||5.008001| +CvSTASH||| +CvWEAKOUTSIDE||| +DECLARATION_FOR_LC_NUMERIC_MANIPULATION||5.021010|n +DEFSV_set|5.010001||p +DEFSV|5.004050||p +DO_UTF8||5.006000| +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|5.006001||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvAV||| +GvCV||| +GvHV||| +GvSV||| +Gv_AMupdate||5.011000| +HEf_SVKEY|5.003070||p +HeHASH||5.003070| +HeKEY||5.003070| +HeKLEN||5.003070| +HePV||5.004000| +HeSVKEY_force||5.003070| +HeSVKEY_set||5.004000| +HeSVKEY||5.003070| +HeUTF8|5.010001|5.008000|p +HeVAL||5.003070| +HvENAMELEN||5.015004| +HvENAMEUTF8||5.015004| +HvENAME||5.013007| +HvNAMELEN_get|5.009003||p +HvNAMELEN||5.015004| +HvNAMEUTF8||5.015004| +HvNAME_get|5.009003||p +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LINKLIST||5.013006| +LVRET||| +MARK||| +MULTICALL||5.024000| +MUTABLE_PTR|5.010001||p +MUTABLE_SV|5.010001||p +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002|5.004050|p +Move||| +NATIVE_TO_NEED||5.007001|n +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +OP_CLASS||5.013007| +OP_DESC||5.007003| +OP_NAME||5.007003| +OP_TYPE_IS_OR_WAS||5.019010| +OP_TYPE_IS||5.019007| +ORIGMARK||| +OpHAS_SIBLING|5.021007||p +OpLASTSIB_set|5.021011||p +OpMAYBESIB_set|5.021011||p +OpMORESIB_set|5.021011||p +OpSIBLING|5.021007||p +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||p +PERL_ARGS_ASSERT_CROAK_XS_USAGE|||p +PERL_BCDVERSION|5.024000||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_HASH|5.003070||p +PERL_INT_MAX|5.003070||p +PERL_INT_MIN|5.003070||p +PERL_LONG_MAX|5.003070||p +PERL_LONG_MIN|5.003070||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.024000||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.024000||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.024000||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.024000||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_PV_ESCAPE_ALL|5.009004||p +PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p +PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p +PERL_PV_ESCAPE_NOCLEAR|5.009004||p +PERL_PV_ESCAPE_QUOTE|5.009004||p +PERL_PV_ESCAPE_RE|5.009005||p +PERL_PV_ESCAPE_UNI_DETECT|5.009004||p +PERL_PV_ESCAPE_UNI|5.009004||p +PERL_PV_PRETTY_DUMP|5.009004||p +PERL_PV_PRETTY_ELLIPSES|5.010000||p +PERL_PV_PRETTY_LTGT|5.009004||p +PERL_PV_PRETTY_NOCLEAR|5.010000||p +PERL_PV_PRETTY_QUOTE|5.009004||p +PERL_PV_PRETTY_REGPROP|5.009004||p +PERL_QUAD_MAX|5.003070||p +PERL_QUAD_MIN|5.003070||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.003070||p +PERL_SHORT_MIN|5.003070||p +PERL_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_SYS_INIT3||5.006000| +PERL_SYS_INIT||| +PERL_SYS_TERM||5.024000| +PERL_UCHAR_MAX|5.003070||p +PERL_UCHAR_MIN|5.003070||p +PERL_UINT_MAX|5.003070||p +PERL_UINT_MIN|5.003070||p +PERL_ULONG_MAX|5.003070||p +PERL_ULONG_MIN|5.003070||p +PERL_UNUSED_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_RESULT|5.021001||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.003070||p +PERL_UQUAD_MIN|5.003070||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.003070||p +PERL_USHORT_MIN|5.003070||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|5.024000||p +PL_bufptr|5.024000||p +PL_check||5.006000| +PL_compiling|5.004050||p +PL_comppad_name||5.017004| +PL_comppad||5.008001| +PL_copline|5.024000||p +PL_curcop|5.004050||p +PL_curpad||5.005000| +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_error_count|5.024000||p +PL_expect|5.024000||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_in_my_stash|5.024000||p +PL_in_my|5.024000||p +PL_keyword_plugin||5.011002| +PL_last_in_gv|||n +PL_laststatval|5.005000||p +PL_lex_state|5.024000||p +PL_lex_stuff|5.024000||p +PL_linestr|5.024000||p +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofsgv|||n +PL_opfreehook||5.011000|n +PL_parser|5.009005||p +PL_peepp||5.007003|n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rpeepp||5.013005|n +PL_rsfp_filters|5.024000||p +PL_rsfp|5.024000||p +PL_rs|||n +PL_signals|5.008001||p +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_statcache|5.005000||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +PL_tokenbuf|5.024000||p +POP_MULTICALL||5.024000| +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +POPul||5.006000|n +POPu||5.004000|n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2nat|5.009003||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.024000| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PadARRAY||5.024000| +PadMAX||5.024000| +PadlistARRAY||5.024000| +PadlistMAX||5.024000| +PadlistNAMESARRAY||5.024000| +PadlistNAMESMAX||5.024000| +PadlistNAMES||5.024000| +PadlistREFCNT||5.017004| +PadnameIsOUR||| +PadnameIsSTATE||| +PadnameLEN||5.024000| +PadnameOURSTASH||| +PadnameOUTER||| +PadnamePV||5.024000| +PadnameREFCNT_dec||5.024000| +PadnameREFCNT||5.024000| +PadnameSV||5.024000| +PadnameTYPE||| +PadnameUTF8||5.021007| +PadnamelistARRAY||5.024000| +PadnamelistMAX||5.024000| +PadnamelistREFCNT_dec||5.024000| +PadnamelistREFCNT||5.024000| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_restore_errno||| +PerlIO_save_errno||| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +READ_XDIGIT||5.017006| +RESTORE_LC_NUMERIC||5.024000| +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +STORE_LC_NUMERIC_FORCE_TO_UNDERLYING||5.024000| +STORE_LC_NUMERIC_SET_TO_NEEDED||5.024000| +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVfARG|5.009005||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_INVLIST||5.019002| +SVt_IV||| +SVt_NULL||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVFM||| +SVt_PVGV||| +SVt_PVHV||| +SVt_PVIO||| +SVt_PVIV||| +SVt_PVLV||| +SVt_PVMG||| +SVt_PVNV||| +SVt_PV||| +SVt_REGEXP||5.011000| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_ro||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_nomg||5.013002| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +SvPV_nolen|5.006000||p +SvPV_nomg_const_nolen|5.009003||p +SvPV_nomg_const|5.009003||p +SvPV_nomg_nolen|5.013007||p +SvPV_nomg|5.007002||p +SvPV_renew|5.009003||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec_NN||5.017007| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK|5.009005||p +SvRX|5.009005||p +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTHINKFIRST||| +SvTRUE_nomg||5.013006| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8SKIP||5.006000| +UTF8_MAXBYTES|5.009002||p +UVCHR_SKIP||5.022000| +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.024000||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +WIDEST_UTYPE|5.015004||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSPROTO|5.010000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_APIVERSION_BOOTCHECK||5.024000| +XS_EXTERNAL||5.024000| +XS_INTERNAL||5.024000| +XS_VERSION_BOOTCHECK||5.024000| +XS_VERSION||| +XSprePUSH|5.006000||p +XS||| +XopDISABLE||5.024000| +XopENABLE||5.024000| +XopENTRYCUSTOM||5.024000| +XopENTRY_set||5.024000| +XopENTRY||5.024000| +XopFLAGS||5.013007| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_add_range_to_invlist||| +_append_range_to_invlist||| +_core_swash_init||| +_get_encoding||| +_get_regclass_nonbitmap_data||| +_get_swash_invlist||| +_invlistEQ||| +_invlist_array_init|||n +_invlist_contains_cp|||n +_invlist_dump||| +_invlist_intersection_maybe_complement_2nd||| +_invlist_intersection||| +_invlist_invert||| +_invlist_len|||n +_invlist_populate_swatch|||n +_invlist_search|||n +_invlist_subtract||| +_invlist_union_maybe_complement_2nd||| +_invlist_union||| +_is_cur_LC_category_utf8||| +_is_in_locale_category||5.021001| +_is_uni_FOO||5.017008| +_is_uni_perl_idcont||5.017008| +_is_uni_perl_idstart||5.017007| +_is_utf8_FOO||5.017008| +_is_utf8_char_slow||5.021001|n +_is_utf8_idcont||5.021001| +_is_utf8_idstart||5.021001| +_is_utf8_mark||5.017008| +_is_utf8_perl_idcont||5.017008| +_is_utf8_perl_idstart||5.017007| +_is_utf8_xidcont||5.021001| +_is_utf8_xidstart||5.021001| +_load_PL_utf8_foldclosures||| +_make_exactf_invlist||| +_new_invlist_C_array||| +_new_invlist||| +_pMY_CXT|5.007003||p +_setlocale_debug_string|||n +_setup_canned_invlist||| +_swash_inversion_hash||| +_swash_to_invlist||| +_to_fold_latin1||| +_to_uni_fold_flags||5.014000| +_to_upper_title_latin1||| +_to_utf8_case||| +_to_utf8_fold_flags||5.019009| +_to_utf8_lower_flags||5.019009| +_to_utf8_title_flags||5.019009| +_to_utf8_upper_flags||5.019009| +_warn_problematic_locale|||n +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHXR_|5.024000||p +aTHXR|5.024000||p +aTHX_|5.006000||p +aTHX|5.006000||p +add_above_Latin1_folds||| +add_cp_to_invlist||| +add_data|||n +add_multi_match||| +add_utf16_textfilter||| +adjust_size_and_find_bucket|||n +advance_one_LB||| +advance_one_SB||| +advance_one_WB||| +alloc_maybe_populate_EXACT||| +alloccopstash||| +allocmy||| +amagic_call||| +amagic_cmp_locale||| +amagic_cmp||| +amagic_deref_call||5.013007| +amagic_i_ncmp||| +amagic_is_enabled||| +amagic_ncmp||| +anonymise_cv_maybe||| +any_dup||| +ao||| +append_utf8_from_native_byte||5.019004|n +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +assert_uft8_cache_coherent||| +assignment_type||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend_guts||| +av_extend||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_tindex||5.017009| +av_top_index||5.017009| +av_undef||| +av_unshift||| +ax|||n +backup_one_LB||| +backup_one_SB||| +backup_one_WB||| +bad_type_gv||| +bad_type_pv||| +bind_match||| +block_end||5.004000| +block_gimme||5.004000| +block_start||5.004000| +blockhook_register||5.013003| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_mro||| +bytes_cmp_utf8||5.013007| +bytes_from_utf8||5.007001| +bytes_to_utf8||5.006001| +cBOOL|5.013000||p +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +caller_cx|5.013005|5.006000|p +calloc||5.007002|n +cando||| +cast_i32||5.006000|n +cast_iv||5.006000|n +cast_ulong||5.006000|n +cast_uv||5.006000|n +check_locale_boundary_crossing||| +check_type_and_open||| +check_uni||| +check_utf8_print||| +checkcomma||| +ckWARN|5.006000||p +ck_entersub_args_core||| +ck_entersub_args_list||5.013006| +ck_entersub_args_proto_or_list||5.013006| +ck_entersub_args_proto||5.013006| +ck_warner_d||5.011001|v +ck_warner||5.011001|v +ckwarn_common||| +ckwarn_d||5.009003| +ckwarn||5.009003| +clear_defarray||5.023008| +clear_placeholders||| +clear_special_blocks||| +clone_params_del|||n +clone_params_new|||n +closest_cop||| +cntrl_to_mnemonic|||n +compute_EXACTish|||n +construct_ahocorasick_from_trie||| +cop_fetch_label||5.015001| +cop_free||| +cop_hints_2hv||5.013007| +cop_hints_fetch_pvn||5.013007| +cop_hints_fetch_pvs||5.013007| +cop_hints_fetch_pv||5.013007| +cop_hints_fetch_sv||5.013007| +cop_store_label||5.015001| +cophh_2hv||5.013007| +cophh_copy||5.013007| +cophh_delete_pvn||5.013007| +cophh_delete_pvs||5.013007| +cophh_delete_pv||5.013007| +cophh_delete_sv||5.013007| +cophh_fetch_pvn||5.013007| +cophh_fetch_pvs||5.013007| +cophh_fetch_pv||5.013007| +cophh_fetch_sv||5.013007| +cophh_free||5.013007| +cophh_new_empty||5.024000| +cophh_store_pvn||5.013007| +cophh_store_pvs||5.013007| +cophh_store_pv||5.013007| +cophh_store_sv||5.013007| +core_prototype||| +coresub_op||| +cr_textfilter||| +create_eval_scope||| +croak_memory_wrap|5.019003||pn +croak_no_mem|||n +croak_no_modify|5.013003||pn +croak_nocontext|||pvn +croak_popstack|||n +croak_sv|5.013001||p +croak_xs_usage|5.010001||pn +croak|||v +csighandler||5.009003|n +current_re_engine||| +curse||| +custom_op_desc||5.007003| +custom_op_get_field||| +custom_op_name||5.007003| +custom_op_register||5.013007| +custom_op_xop||5.013007| +cv_ckproto_len_flags||| +cv_clone_into||| +cv_clone||| +cv_const_sv_or_av|||n +cv_const_sv||5.003070|n +cv_dump||| +cv_forget_slab||| +cv_get_call_checker||5.013006| +cv_name||5.021005| +cv_set_call_checker_flags||5.021004| +cv_set_call_checker||5.013006| +cv_undef_flags||| +cv_undef||| +cvgv_from_hek||| +cvgv_set||| +cvstash_set||| +cx_dump||5.005000| +cx_dup||| +cx_popblock||5.023008| +cx_popeval||5.023008| +cx_popformat||5.023008| +cx_popgiven||5.023008| +cx_poploop||5.023008| +cx_popsub_args||5.023008| +cx_popsub_common||5.023008| +cx_popsub||5.023008| +cx_popwhen||5.023008| +cx_pushblock||5.023008| +cx_pusheval||5.023008| +cx_pushformat||5.023008| +cx_pushgiven||5.023008| +cx_pushloop_for||5.023008| +cx_pushloop_plain||5.023008| +cx_pushsub||5.023008| +cx_pushwhen||5.023008| +cx_topblock||5.023008| +cxinc||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.024000||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +defelem_target||| +del_sv||| +delete_eval_scope||| +delimcpy||5.004000|n +deprecate_commaless_var_list||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_sv|5.013001||p +die_unwind||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_close||| +do_delete_local||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_ncmp||| +do_oddball||| +do_op_dump||5.006000| +do_open6||| +do_open9||5.006000| +do_open_raw||| +do_openn||5.007001| +do_open||5.003070| +do_pmop_dump||5.006000| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch||| +doeval_compile||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogivenfor||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +drand48_init_r|||n +drand48_r|||n +dtrace_probe_call||| +dtrace_probe_load||| +dtrace_probe_op||| +dtrace_probe_phase||| +dump_all_perl||| +dump_all||5.006000| +dump_c_backtrace||| +dump_eval||5.006000| +dump_exec_pos||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs_perl||| +dump_packsubs||5.006000| +dump_sub_perl||| +dump_sub||5.006000| +dump_sv_child||| +dump_trie_interim_list||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +edit_distance|||n +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +feature_is_enabled||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +finalize_optree||| +finalize_op||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_default_stash||| +find_hash_subscript||| +find_in_my_stash||| +find_lexical_cv||| +find_runcv_where||| +find_runcv||5.008001| +find_rundefsvoffset||5.009002| +find_rundefsv||5.013002| +find_script||| +find_uninit_var||| +first_symbol|||n +fixup_errno_string||| +foldEQ_latin1||5.013008|n +foldEQ_locale||5.013002|n +foldEQ_utf8_flags||5.013010| +foldEQ_utf8||5.013002| +foldEQ||5.013002|n +fold_constants||| +forbid_setid||| +force_ident_maybe_lex||| +force_ident||| +force_list||| +force_next||| +force_strict_version||| +force_version||| +force_word||| +forget_pmop||| +form_nocontext|||vn +form_short_octal_warning||| +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_c_backtrace||| +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_ANYOF_cp_list_for_ssc||| +get_and_check_backslash_N_name||| +get_aux_mg||| +get_av|5.006000||p +get_c_backtrace_dump||| +get_c_backtrace||| +get_context||5.006000|n +get_cvn_flags||| +get_cvs|5.011000||p +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_invlist_iter_addr|||n +get_invlist_offset_addr|||n +get_invlist_previous_index_addr|||n +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_assign_glob||| +gp_dup||| +gp_free||| +gp_ref||| +grok_atoUV|||n +grok_bin|5.007003||p +grok_bslash_N||| +grok_bslash_c||| +grok_bslash_o||| +grok_bslash_x||| +grok_hex|5.007003||p +grok_infnan||5.021004| +grok_number_flags||5.021002| +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_SVadd||| +gv_add_by_type||5.011000| +gv_autoload4||5.004000| +gv_autoload_pvn||5.015004| +gv_autoload_pv||5.015004| +gv_autoload_sv||5.015004| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.003070| +gv_efullname4||5.006001| +gv_efullname||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmeth_internal||| +gv_fetchmeth_pv_autoload||5.015004| +gv_fetchmeth_pvn_autoload||5.015004| +gv_fetchmeth_pvn||5.015004| +gv_fetchmeth_pv||5.015004| +gv_fetchmeth_sv_autoload||5.015004| +gv_fetchmeth_sv||5.015004| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_pv_flags||5.015004| +gv_fetchmethod_pvn_flags||5.015004| +gv_fetchmethod_sv_flags||5.015004| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags|5.009002||p +gv_fetchpvs|5.009004||p +gv_fetchpv||| +gv_fetchsv||| +gv_fullname3||5.003070| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_pvn||| +gv_init_pv||5.015004| +gv_init_svtype||| +gv_init_sv||5.015004| +gv_init||| +gv_is_in_main||| +gv_magicalize_isa||| +gv_magicalize||| +gv_name_set||5.009004| +gv_override||| +gv_setref||| +gv_stashpvn_internal||| +gv_stashpvn|5.003070||p +gv_stashpvs|5.009003||p +gv_stashpv||| +gv_stashsvpvn_cached||| +gv_stashsv||| +gv_try_downgrade||| +handle_named_backref||| +handle_possible_posix||| +handle_regex_sets||| +he_dup||| +hek_dup||| +hfree_next_entry||| +hsplit||| +hv_assert||| +hv_auxinit_internal|||n +hv_auxinit||| +hv_backreferences_p||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_common_key_len||5.010000| +hv_common||5.010000| +hv_copy_hints_hv||5.009004| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.003070| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_ename_add||| +hv_ename_delete||| +hv_exists_ent||5.003070| +hv_exists||| +hv_fetch_ent||5.003070| +hv_fetchs|5.009003||p +hv_fetch||| +hv_fill||5.013002| +hv_free_ent_ret||| +hv_free_entries||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.003070| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_kill_backrefs||| +hv_ksplit||5.003070| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||| +hv_placeholders_set||5.009003| +hv_rand_set||5.018000| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.003070| +hv_store_flags||5.008000| +hv_stores|5.009004||p +hv_store||| +hv_undef_flags||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incline||| +incpush_if_exists||| +incpush_use_sep||| +incpush||| +ingroup||| +init_argv_symbols||| +init_constants||| +init_dbargs||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +inplace_aassign||| +instr|||n +intro_my||5.004000| +intuit_method||| +intuit_more||| +invert||| +invlist_array|||n +invlist_clear||| +invlist_clone||| +invlist_contents||| +invlist_extend||| +invlist_highest|||n +invlist_is_iterating|||n +invlist_iterfinish|||n +invlist_iterinit|||n +invlist_iternext|||n +invlist_max|||n +invlist_previous_index|||n +invlist_replace_list_destroys_src||| +invlist_set_len||| +invlist_set_previous_index|||n +invlist_trim|||n +invoke_exception_hook||| +io_close||| +isALNUMC|5.006000||p +isALNUM_lazy||5.021001| +isALPHANUMERIC||5.017008| +isALPHA||| +isASCII|5.006000||p +isBLANK|5.006001||p +isCNTRL|5.006000||p +isDIGIT||| +isFOO_lc||| +isFOO_utf8_lc||| +isGCB|||n +isGRAPH|5.006000||p +isIDCONT||5.017008| +isIDFIRST_lazy||5.021001| +isIDFIRST||| +isLB||| +isLOWER||| +isOCTAL||5.013005| +isPRINT|5.004000||p +isPSXSPC|5.006001||p +isPUNCT|5.006000||p +isSB||| +isSPACE||| +isUPPER||| +isUTF8_CHAR||5.021001| +isWB||| +isWORDCHAR||5.013006| +isXDIGIT|5.006000||p +is_an_int||| +is_ascii_string||5.011000| +is_handle_constructor|||n +is_invariant_string||5.021007|n +is_lvalue_sub||5.007001| +is_safe_syscall||5.019004| +is_ssc_worth_it|||n +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.017007| +is_uni_alnumc||5.017007| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_blank_lc||5.017002| +is_uni_blank||5.017002| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.017007| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_blank||5.017002| +is_utf8_char_buf||5.015008|n +is_utf8_char||5.006000|n +is_utf8_cntrl||5.006000| +is_utf8_common||| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_perl_space||5.011001| +is_utf8_perl_word||5.011001| +is_utf8_posix_digit||5.011001| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003|n +is_utf8_string_loc||5.008001|n +is_utf8_string||5.006001|n +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +is_utf8_xidcont||5.013010| +is_utf8_xidfirst||5.013010| +isa_lookup||| +isinfnansv||| +isinfnan||5.021004|n +items|||n +ix|||n +jmaybe||| +join_exact||| +keyword_plugin_standard||| +keyword||| +leave_adjust_stacks||5.023008| +leave_scope||| +lex_bufutf8||5.011002| +lex_discard_to||5.011002| +lex_grow_linestr||5.011002| +lex_next_chunk||5.011002| +lex_peek_unichar||5.011002| +lex_read_space||5.011002| +lex_read_to||5.011002| +lex_read_unichar||5.011002| +lex_start||5.009005| +lex_stuff_pvn||5.011002| +lex_stuff_pvs||5.013005| +lex_stuff_pv||5.013006| +lex_stuff_sv||5.011002| +lex_unstuff||5.011002| +listkids||| +list||| +load_module_nocontext|||vn +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.010001||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHs|5.010001||p +mXPUSHu|5.009002||p +magic_clear_all_env||| +magic_cleararylen_p||| +magic_clearenv||| +magic_clearhints||| +magic_clearhint||| +magic_clearisa||| +magic_clearpack||| +magic_clearsig||| +magic_copycallchecker||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdebugvar||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_methcall1||| +magic_methcall|||v +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdebugvar||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +magic_setisa||| +magic_setlvref||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +make_matcher||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +markstack_grow||5.021001| +matcher_matches_sv||| +maybe_multimagic_gv||| +mayberelocate||| +measure_struct||| +memEQs|5.009005||p +memEQ|5.004000||p +memNEs|5.009005||p +memNE|5.004000||p +mem_collxfrm||| +mem_log_alloc|||n +mem_log_common|||n +mem_log_free|||n +mem_log_realloc|||n +mess_alloc||| +mess_nocontext|||pvn +mess_sv|5.013001||p +mess|5.006000||pv +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find_mglob||| +mg_findext|5.013008||pn +mg_find|||n +mg_free_type||5.013006| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical|||n +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002|n +minus_v||| +missingterm||| +mode_from_discipline||| +modkids||| +more_bodies||| +more_sv||| +moreswitches||| +move_proto_attr||| +mro_clean_isarev||| +mro_gather_and_rename||| +mro_get_from_name||5.010001| +mro_get_linear_isa_dfs||| +mro_get_linear_isa||5.009005| +mro_get_private_data||5.010001| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +mro_package_moved||| +mro_register||5.010001| +mro_set_mro||5.010001| +mro_set_private_data||5.010001| +mul128||| +mulexp10|||n +multideref_stringify||| +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy||5.004050|n +my_bytes_to_utf8|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005|n +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_kid||| +my_lstat_flags||| +my_lstat||5.024000| +my_memcmp|||n +my_memset|||n +my_pclose||5.003070| +my_popen_list||5.007001| +my_popen||5.003070| +my_setenv||| +my_setlocale||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat_flags||| +my_stat||5.024000| +my_strerror||5.021001| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_unexec||| +my_vsnprintf||5.009004|n +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB_x||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB_flags||5.015006| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||5.021006| +newFORM||| +newFOROP||5.013007| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen_flags||5.015004| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMETHOP_internal||| +newMETHOP_named||5.021005| +newMETHOP||5.021005| +newMYSUB||5.017004| +newNULLLIST||| +newOP||| +newPADNAMELIST||5.021007|n +newPADNAMEouter||5.021007|n +newPADNAMEpvn||5.021007|n +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSTUB||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type|5.009005||p +newSVavdefelem||| +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpadname||5.017004| +newSVpv_share||5.013006| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.010001||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.010001||p +newSVpvn|5.004050||p +newSVpvs_flags|5.010001||p +newSVpvs_share|5.009003||p +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newUNOP_AUX||5.021007| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.013007| +newXS_deffile||| +newXS_flags||5.009004| +newXS_len_flags||| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr|||n +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +noperl_die|||vn +not_a_number||| +not_incrementable||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsHV||| +op_append_elem||5.013006| +op_append_list||5.013006| +op_clear||| +op_contextualize||5.013006| +op_convert_list||5.021006| +op_dump||5.006000| +op_free||| +op_integerize||| +op_linklist||5.013006| +op_lvalue_flags||| +op_lvalue||5.013007| +op_null||5.007002| +op_parent|||n +op_prepend_elem||5.013006| +op_refcnt_dec||| +op_refcnt_inc||| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +op_relocate_sv||| +op_scope||5.013007| +op_sibling_splice||5.021002|n +op_std_init||| +op_unscope||| +open_script||| +openn_cleanup||| +openn_setup||| +opmethod_stash||| +opslab_force_free||| +opslab_free_nopad||| +opslab_free||| +output_or_return_posix_warnings||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +packWARN|5.007003||p +pack_cat||5.007003| +pack_rec||| +package_version||| +package||| +packlist||5.008001| +pad_add_anon||5.008001| +pad_add_name_pvn||5.015001| +pad_add_name_pvs||5.015001| +pad_add_name_pv||5.015001| +pad_add_name_sv||5.015001| +pad_add_weakref||| +pad_alloc_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||5.009003| +pad_findlex||| +pad_findmy_pvn||5.015001| +pad_findmy_pvs||5.015001| +pad_findmy_pv||5.015001| +pad_findmy_sv||5.015001| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||5.008001| +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||5.008001| +padlist_dup||| +padlist_store||| +padname_dup||| +padname_free||| +padnamelist_dup||| +padnamelist_fetch||5.021007|n +padnamelist_free||| +padnamelist_store||5.021007| +parse_arithexpr||5.013008| +parse_barestmt||5.013007| +parse_block||5.013007| +parse_body||| +parse_fullexpr||5.013008| +parse_fullstmt||5.013005| +parse_gv_stash_name||| +parse_ident||| +parse_label||5.013007| +parse_listexpr||5.013008| +parse_lparen_question_flags||| +parse_stmtseq||5.013006| +parse_subsignature||| +parse_termexpr||5.013008| +parse_unicode_opts||| +parser_dup||| +parser_free_nexttoke_ops||| +parser_free||| +path_is_searchable|||n +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pm_description||| +pmop_dump||5.006000| +pmruntime||| +pmtrans||| +pop_scope||| +populate_ANYOF_from_invlist||| +populate_isa|||v +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prescan_version||5.011004| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_hash|||n +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_charclass_bitmap_innards_common||| +put_charclass_bitmap_innards_invlist||| +put_charclass_bitmap_innards||| +put_code_point||| +put_range||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +quadmath_format_needed|||n +quadmath_format_single|||n +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_exec_indentf|||v +re_indentf|||v +re_intuit_start||5.019001| +re_intuit_string||5.006000| +re_op_compile||| +re_printf|||v +realloc||5.007002|n +reentrant_free||5.024000| +reentrant_init||5.024000| +reentrant_retry||5.024000|vn +reentrant_size||5.024000| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch_pvn||| +refcounted_he_fetch_pvs||| +refcounted_he_fetch_pv||| +refcounted_he_fetch_sv||| +refcounted_he_free||| +refcounted_he_inc||| +refcounted_he_new_pvn||| +refcounted_he_new_pvs||| +refcounted_he_new_pv||| +refcounted_he_new_sv||| +refcounted_he_value||| +refkids||| +refto||| +ref||5.024000| +reg2Lanode||| +reg_check_named_buff_matched|||n +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment|||n +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly|||n +regdump_extflags||| +regdump_intflags||| +regdump||5.005000| +regdupe_internal||| +regex_set_precedence|||n +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regnode_guts||| +regpiece||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reg||| +repeatcpy|||n +report_evil_fh||| +report_redefined_cv||| +report_uninit||| +report_wrongway_fh||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr|||n +rpeep||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rv2cv_op_cv||5.013006| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_adelete||5.011000| +save_aelem_flags||5.011000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hdelete||5.011000| +save_hek_flags|||n +save_helem_flags||5.011000| +save_helem||5.004050| +save_hints||5.010001| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic_flags||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||5.005000| +save_padsv_and_mortalize||5.010001| +save_pptr||| +save_pushi32ptr||5.010001| +save_pushptri32ptr||| +save_pushptrptr||5.010001| +save_pushptr||5.010001| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_strlen||| +save_svref||| +save_vptr||5.006000| +savepvn||| +savepvs||5.009003| +savepv||| +savesharedpvn||5.009005| +savesharedpvs||5.013006| +savesharedpv||5.007003| +savesharedsvpv||5.013006| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +savetmps||5.023008| +sawparens||| +scalar_mod_type|||n +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.009005| +scan_word||| +search_const||| +seed||5.008001| +sequence_num||| +set_ANYOF_arg||| +set_caret_X||| +set_context||5.006000|n +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +set_padlist|||n +setdefout||| +share_hek_flags||| +share_hek||5.004000| +should_warn_nl|||n +si_dup||| +sighandler|||n +simplify_sort||| +skip_to_be_ignored_text||| +skipspace_flags||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +ssc_add_range||| +ssc_and||| +ssc_anything||| +ssc_clear_locale|||n +ssc_cp_and||| +ssc_finalize||| +ssc_init||| +ssc_intersection||| +ssc_is_anything|||n +ssc_is_cp_posixl_init|||n +ssc_or||| +ssc_union||| +stack_grow||| +start_glob||| +start_subparse||5.004000| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool_flags||5.013006| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv_flags||5.013001| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff|||n +sv_bless||| +sv_buf_to_ro||| +sv_buf_to_rw||| +sv_cat_decode||5.008001| +sv_catpv_flags||5.013006| +sv_catpv_mg|5.004050||p +sv_catpv_nomg||5.013006| +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.004050||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpvs_flags||5.013006| +sv_catpvs_mg||5.013006| +sv_catpvs_nomg||5.013006| +sv_catpvs|5.009003||p +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.004050||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_flags||5.013006| +sv_cmp_locale_flags||5.013006| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm_flags||5.013006| +sv_collxfrm||| +sv_copypv_flags||5.017002| +sv_copypv_nomg||5.017002| +sv_copypv||| +sv_dec_nomg||5.013002| +sv_dec||| +sv_del_backref||| +sv_derived_from_pvn||5.015004| +sv_derived_from_pv||5.015004| +sv_derived_from_sv||5.015004| +sv_derived_from||5.004000| +sv_destroyable||5.010000| +sv_display||| +sv_does_pvn||5.015004| +sv_does_pv||5.015004| +sv_does_sv||5.015004| +sv_does||5.009004| +sv_dump||| +sv_dup_common||| +sv_dup_inc_multiple||| +sv_dup_inc||| +sv_dup||| +sv_eq_flags||5.013006| +sv_eq||| +sv_exp_grow||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_get_backrefs||5.021008|n +sv_gets||5.003070| +sv_grow||| +sv_i_ncmp||| +sv_inc_nomg||5.013002| +sv_inc||| +sv_insert_flags||5.010001| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8_nomg||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.024000|5.004000|p +sv_magicext_mglob||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy_flags||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_only_taint_gmagic|||n +sv_or_pv_pos_u2b||| +sv_peek||5.005000| +sv_pos_b2u_flags||5.019003| +sv_pos_b2u_midway||| +sv_pos_b2u||5.006000| +sv_pos_u2b_cached||| +sv_pos_u2b_flags||5.011005| +sv_pos_u2b_forwards|||n +sv_pos_u2b_midway|||n +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_ref||5.015004| +sv_replace||| +sv_report_used||| +sv_resetpvn||| +sv_reset||| +sv_rvweaken||5.006000| +sv_sethek||| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.004050||p +sv_setpvn||| +sv_setpvs_mg||5.013006| +sv_setpvs|5.009004||p +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pvs||5.024000| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagicext|5.013008||p +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags_grow||5.011000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade_nomg||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn_flags||5.017002| +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +swash_scan_list_line||| +swatch_get||| +sync_locale||5.021004| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tied_method|||v +tmps_grow_p||| +toFOLD_utf8||5.019001| +toFOLD_uvchr||5.023009| +toFOLD||5.019001| +toLOWER_L1||5.019001| +toLOWER_LC||5.004000| +toLOWER_utf8||5.015007| +toLOWER_uvchr||5.023009| +toLOWER||| +toTITLE_utf8||5.015007| +toTITLE_uvchr||5.023009| +toTITLE||5.019001| +toUPPER_utf8||5.015007| +toUPPER_uvchr||5.023009| +toUPPER||| +to_byte_substr||| +to_lower_latin1|||n +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.015007| +to_utf8_lower||5.015007| +to_utf8_substr||| +to_utf8_title||5.015007| +to_utf8_upper||5.015007| +tokenize_use||| +tokeq||| +tokereport||| +too_few_arguments_pv||| +too_many_arguments_pv||| +translate_substr_offsets|||n +try_amagic_bin||| +try_amagic_un||| +uiv_2buf|||n +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unreferenced_to_tmp_stack||| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.003070| +unwind_handler_stack||| +update_debugger_info||| +upg_version||5.009005| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf8_distance||5.006000| +utf8_hop||5.006000|n +utf8_length||5.007001| +utf8_mg_len_cache_update||| +utf8_mg_pos_cache_update||| +utf8_to_bytes||5.006001| +utf8_to_uvchr_buf||5.015009| +utf8_to_uvchr||5.007001| +utf8_to_uvuni_buf||5.015009| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||5.007001| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||5.007001| +uvoffuni_to_utf8_flags||5.019004| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +valid_utf8_to_uvchr||5.015009| +valid_utf8_to_uvuni||5.015009| +validate_proto||| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess|5.006000||p +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||pvn +warn_sv|5.013001||p +warner_nocontext|||vn +warner|5.006000|5.004000|pv +warn|||v +was_lvalue_sub||| +watch||| +whichsig_pvn||5.015004| +whichsig_pv||5.015004| +whichsig_sv||5.015004| +whichsig||| +win32_croak_not_implemented|||n +with_queued_errors||| +wrap_op_checker||5.015008| +write_to_stderr||| +xs_boot_epilog||| +xs_handshake|||vn +xs_version_bootcheck||| +yyerror_pvn||| +yyerror_pv||| +yyerror||| +yylex||| +yyparse||| +yyunlex||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while () { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; }; + close IN; + + my %file = (orig => $c, changes => 0); + + # Temporarily remove C/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + $file{uses_provided}{$func}++; + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { warning("Possibly wrong #define $1 in $filename") } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub try_use { eval "use @_;"; return $@ eq '' } + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and try_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <
$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while () { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print < }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define D_PPP_DEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((D_PPP_DEC2BCD(PERL_REVISION)<<24)|(D_PPP_DEC2BCD(PERL_VERSION)<<12)|D_PPP_DEC2BCD(PERL_SUBVERSION)) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#ifdef I_LIMITS +# include +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef LONGSIZE +# define LONGSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef LONGSIZE +# define LONGSIZE 4 +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef memEQs +# define memEQs(s1, l, s2) \ + (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) +#endif + +#ifndef memNEs +# define memNEs(s1, l, s2) !memEQs(s1, l, s2) +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) +#endif + +#endif +#ifndef PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif + +/* Some random bits for sv_unmagicext. These should probably be pulled in for + real and organized at some point */ +#ifndef HEf_SVKEY +# define HEf_SVKEY -2 +#endif + +#ifndef MUTABLE_PTR +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) +#else +# define MUTABLE_PTR(p) ((void *) (p)) +#endif +#endif +#ifndef MUTABLE_SV +# define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) +#endif + +/* end of random bits */ +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#endif + +#if !defined(mg_findext) +#if defined(NEED_mg_findext) +static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +static +#else +extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +#endif + +#if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) + +#define mg_findext DPPP_(my_mg_findext) +#define Perl_mg_findext DPPP_(my_mg_findext) + + +MAGIC * +DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { + if (sv) { + MAGIC *mg; + +#ifdef AvPAD_NAMELIST + assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); +#endif + + for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { + if (mg->mg_type == type && mg->mg_virtual == vtbl) + return mg; + } + } + + return NULL; +} + +#endif +#endif + +#if !defined(sv_unmagicext) +#if defined(NEED_sv_unmagicext) +static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +static +#else +extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +#endif + +#if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) + +#ifdef sv_unmagicext +# undef sv_unmagicext +#endif +#define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) +#define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) + + +int +DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) +{ + MAGIC* mg; + MAGIC** mgp; + + if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) + return 0; + mgp = &(SvMAGIC(sv)); + for (mg = *mgp; mg; mg = *mgp) { + const MGVTBL* const virt = mg->mg_virtual; + if (mg->mg_type == type && virt == vtbl) { + *mgp = mg->mg_moremagic; + if (virt && virt->svt_free) + virt->svt_free(aTHX_ sv, mg); + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { + if (mg->mg_len > 0) + Safefree(mg->mg_ptr); + else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); + else if (mg->mg_type == PERL_MAGIC_utf8) + Safefree(mg->mg_ptr); + } + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + Safefree(mg); + } + else + mgp = &mg->mg_moremagic; + } + if (SvMAGIC(sv)) { + if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ + mg_magical(sv); /* else fix the flags now */ + } + else { + SvMAGICAL_off(sv); + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + } + return 0; +} + +#endif +#endif +#ifndef cBOOL +# define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) +#endif + +#ifndef OpHAS_SIBLING +# define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) +#endif + +#ifndef OpSIBLING +# define OpSIBLING(o) (0 + (o)->op_sibling) +#endif + +#ifndef OpMORESIB_set +# define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) +#endif + +#ifndef OpLASTSIB_set +# define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) +#endif + +#ifndef OpMAYBESIB_set +# define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) +#endif + +#ifndef SvRX +#if defined(NEED_SvRX) +static void * DPPP_(my_SvRX)(pTHX_ SV *rv); +static +#else +extern void * DPPP_(my_SvRX)(pTHX_ SV *rv); +#endif + +#if defined(NEED_SvRX) || defined(NEED_SvRX_GLOBAL) + +#ifdef SvRX +# undef SvRX +#endif +#define SvRX(a) DPPP_(my_SvRX)(aTHX_ a) + + +void * +DPPP_(my_SvRX)(pTHX_ SV *rv) +{ + if (SvROK(rv)) { + SV *sv = SvRV(rv); + if (SvMAGICAL(sv)) { + MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); + if (mg && mg->mg_obj) { + return mg->mg_obj; + } + } + } + return 0; +} +#endif +#endif +#ifndef SvRXOK +# define SvRXOK(sv) (!!SvRX(sv)) +#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 PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif + +#ifndef PERL_UNUSED_RESULT +# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) +# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END +# else +# define PERL_UNUSED_RESULT(v) ((void)(v)) +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif +#endif + +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) +#endif + +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) +#endif + +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) +#endif + +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif + +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) +#endif + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) +#endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif + +#ifndef WIDEST_UTYPE +# ifdef QUADKIND +# ifdef U64TYPE +# define WIDEST_UTYPE U64TYPE +# else +# define WIDEST_UTYPE Quad_t +# endif +# else +# define WIDEST_UTYPE U32 +# endif +#endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +/* Until we figure out how to support this in older perls... */ +#if (PERL_BCDVERSION >= 0x5008000) +#ifndef HeUTF8 +# define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ + SvUTF8(HeKEY_sv(he)) : \ + (U32)HeKUTF8(he)) +#endif + +#endif +#ifndef C_ARRAY_LENGTH +# define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) +#endif + +#ifndef C_ARRAY_END +# define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# elif IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# else +# error "cannot define IV/UV formats" +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifdef NEED_mess_sv +#define NEED_mess +#endif + +#ifdef NEED_mess +#define NEED_mess_nocontext +#define NEED_vmess +#endif + +#ifndef croak_sv +#if (PERL_BCDVERSION >= 0x5007003) || ( (PERL_BCDVERSION >= 0x5006001) && (PERL_BCDVERSION < 0x5007000) ) +# if ( (PERL_BCDVERSION >= 0x5008000) && (PERL_BCDVERSION < 0x5008009) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5010001) ) +# define D_PPP_FIX_UTF8_ERRSV(errsv, sv) \ + STMT_START { \ + if (sv != ERRSV) \ + SvFLAGS(ERRSV) = (SvFLAGS(ERRSV) & ~SVf_UTF8) | \ + (SvFLAGS(sv) & SVf_UTF8); \ + } STMT_END +# else +# define D_PPP_FIX_UTF8_ERRSV(errsv, sv) STMT_START {} STMT_END +# endif +# define croak_sv(sv) \ + STMT_START { \ + if (SvROK(sv)) { \ + sv_setsv(ERRSV, sv); \ + croak(NULL); \ + } else { \ + D_PPP_FIX_UTF8_ERRSV(ERRSV, sv); \ + croak("%" SVf, SVfARG(sv)); \ + } \ + } STMT_END +#elif (PERL_BCDVERSION >= 0x5004000) +# define croak_sv(sv) croak("%" SVf, SVfARG(sv)) +#else +# define croak_sv(sv) croak("%s", SvPV_nolen(sv)) +#endif +#endif + +#ifndef die_sv +#if defined(NEED_die_sv) +static OP * DPPP_(my_die_sv)(pTHX_ SV *sv); +static +#else +extern OP * DPPP_(my_die_sv)(pTHX_ SV *sv); +#endif + +#if defined(NEED_die_sv) || defined(NEED_die_sv_GLOBAL) + +#ifdef die_sv +# undef die_sv +#endif +#define die_sv(a) DPPP_(my_die_sv)(aTHX_ a) +#define Perl_die_sv DPPP_(my_die_sv) + +OP * +DPPP_(my_die_sv)(pTHX_ SV *sv) +{ + croak_sv(sv); + return (OP *)NULL; +} +#endif +#endif + +#ifndef warn_sv +#if (PERL_BCDVERSION >= 0x5004000) +# define warn_sv(sv) warn("%" SVf, SVfARG(sv)) +#else +# define warn_sv(sv) warn("%s", SvPV_nolen(sv)) +#endif +#endif + +#ifndef vmess +#if defined(NEED_vmess) +static SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); +static +#else +extern SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); +#endif + +#if defined(NEED_vmess) || defined(NEED_vmess_GLOBAL) + +#ifdef vmess +# undef vmess +#endif +#define vmess(a,b) DPPP_(my_vmess)(aTHX_ a,b) +#define Perl_vmess DPPP_(my_vmess) + +SV* +DPPP_(my_vmess)(pTHX_ const char* pat, va_list* args) +{ + mess(pat, args); + return PL_mess_sv; +} +#endif +#endif + +#if (PERL_BCDVERSION < 0x5006000) +#undef mess +#endif + +#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) +#if defined(NEED_mess_nocontext) +static SV * DPPP_(my_mess_nocontext)(const char * pat, ...); +static +#else +extern SV * DPPP_(my_mess_nocontext)(const char * pat, ...); +#endif + +#if defined(NEED_mess_nocontext) || defined(NEED_mess_nocontext_GLOBAL) + +#define mess_nocontext DPPP_(my_mess_nocontext) +#define Perl_mess_nocontext DPPP_(my_mess_nocontext) + +SV* +DPPP_(my_mess_nocontext)(const char* pat, ...) +{ + dTHX; + SV *sv; + va_list args; + va_start(args, pat); + sv = vmess(pat, &args); + va_end(args); + return sv; +} +#endif +#endif + +#ifndef mess +#if defined(NEED_mess) +static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); +static +#else +extern SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); +#endif + +#if defined(NEED_mess) || defined(NEED_mess_GLOBAL) + +#define Perl_mess DPPP_(my_mess) + +SV* +DPPP_(my_mess)(pTHX_ const char* pat, ...) +{ + SV *sv; + va_list args; + va_start(args, pat); + sv = vmess(pat, &args); + va_end(args); + return sv; +} +#ifdef mess_nocontext +#define mess mess_nocontext +#else +#define mess Perl_mess_nocontext +#endif +#endif +#endif + +#ifndef mess_sv +#if defined(NEED_mess_sv) +static SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); +static +#else +extern SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); +#endif + +#if defined(NEED_mess_sv) || defined(NEED_mess_sv_GLOBAL) + +#ifdef mess_sv +# undef mess_sv +#endif +#define mess_sv(a,b) DPPP_(my_mess_sv)(aTHX_ a,b) +#define Perl_mess_sv DPPP_(my_mess_sv) + +SV * +DPPP_(my_mess_sv)(pTHX_ SV *basemsg, bool consume) +{ + SV *tmp; + SV *ret; + + if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') { + if (consume) + return basemsg; + ret = mess(""); + SvSetSV_nosteal(ret, basemsg); + return ret; + } + + if (consume) { + sv_catsv(basemsg, mess("")); + return basemsg; + } + + ret = mess(""); + tmp = newSVsv(ret); + SvSetSV_nosteal(ret, basemsg); + sv_catsv(ret, tmp); + sv_dec(tmp); + return ret; +} +#endif +#endif + +#ifndef warn_nocontext +#define warn_nocontext warn +#endif + +#ifndef croak_nocontext +#define croak_nocontext croak +#endif + +#ifndef croak_no_modify +#define croak_no_modify() croak_nocontext("%s", PL_no_modify) +#define Perl_croak_no_modify() croak_no_modify() +#endif + +#ifndef croak_memory_wrap +#if (PERL_BCDVERSION >= 0x5009002) || ( (PERL_BCDVERSION >= 0x5008006) && (PERL_BCDVERSION < 0x5009000) ) +# define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap) +#else +# define croak_memory_wrap() croak_nocontext("panic: memory wrap") +#endif +#endif + +#ifndef croak_xs_usage +#if defined(NEED_croak_xs_usage) +static void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); +static +#else +extern void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); +#endif + +#if defined(NEED_croak_xs_usage) || defined(NEED_croak_xs_usage_GLOBAL) + +#define croak_xs_usage DPPP_(my_croak_xs_usage) +#define Perl_croak_xs_usage DPPP_(my_croak_xs_usage) + + +#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE +#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) +#endif + +void +DPPP_(my_croak_xs_usage)(const CV *const cv, const char *const params) +{ + dTHX; + const GV *const gv = CvGV(cv); + + PERL_ARGS_ASSERT_CROAK_XS_USAGE; + + if (gv) { + const char *const gvname = GvNAME(gv); + const HV *const stash = GvSTASH(gv); + const char *const hvname = stash ? HvNAME(stash) : NULL; + + if (hvname) + croak("Usage: %s::%s(%s)", hvname, gvname, params); + else + croak("Usage: %s(%s)", gvname, params); + } else { + /* Pants. I don't think that it should be possible to get here. */ + croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); + } +} +#endif +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_error_count error_count +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doing. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) + + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUEx(ERRSV)) + croak_sv(ERRSV); + + return sv; +} + +#endif +#endif + +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#elif (PERL_BCDVERSION > 0x5003000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#endif + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +static +#else +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#endif + +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) + +#ifdef newSV_type +# undef newSV_type +#endif +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) + + +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) +{ + SV* const sv = newSV(0); + sv_upgrade(sv, t); + return sv; +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +#endif + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define D_PPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define D_PPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif + +#ifndef SvPV_nomg_nolen +# define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, 0)) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#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 + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#endif + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* Hint: newSVpvn_share + * The SVs created by this function only mimic the behaviour of + * shared PVs without really being shared. Only use if you know + * what you're doing. + */ + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) +#endif +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) +#endif + +#ifndef gv_fetchpvn_flags +#if defined(NEED_gv_fetchpvn_flags) +static GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); +static +#else +extern GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); +#endif + +#if defined(NEED_gv_fetchpvn_flags) || defined(NEED_gv_fetchpvn_flags_GLOBAL) + +#ifdef gv_fetchpvn_flags +# undef gv_fetchpvn_flags +#endif +#define gv_fetchpvn_flags(a,b,c,d) DPPP_(my_gv_fetchpvn_flags)(aTHX_ a,b,c,d) +#define Perl_gv_fetchpvn_flags DPPP_(my_gv_fetchpvn_flags) + + +GV* +DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types) { + char *namepv = savepvn(name, len); + GV* stash = gv_fetchpv(namepv, TRUE, SVt_PVHV); + Safefree(namepv); + return stash; +} + +#endif +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) +#endif + +#ifndef isGV_with_GP +# define isGV_with_GP(gv) isGV(gv) +#endif + +#ifndef gv_fetchsv +# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) +#endif +#ifndef get_cvn_flags +# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) +#endif + +#ifndef gv_init_pvn +# define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 +#endif + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +#define Perl_warner DPPP_(my_warner) + + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#endif + +#ifndef newSVpvs_share +# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) +#endif + +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif + +#ifndef gv_stashpvs +# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) +#endif +#ifndef get_cvs +# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ + +#if (PERL_BCDVERSION >= 0x5006000) +#ifndef caller_cx + +# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) +static I32 +DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) +{ + I32 i; + + for (i = startingblock; i >= 0; i--) { + register const PERL_CONTEXT * const cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_EVAL: + case CXt_SUB: + case CXt_FORMAT: + return i; + } + } + return i; +} +# endif + +# if defined(NEED_caller_cx) +static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); +static +#else +extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); +#endif + +#if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) + +#ifdef caller_cx +# undef caller_cx +#endif +#define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b) +#define Perl_caller_cx DPPP_(my_caller_cx) + + +const PERL_CONTEXT * +DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) +{ + register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); + register const PERL_CONTEXT *cx; + register const PERL_CONTEXT *ccstack = cxstack; + const PERL_SI *top_si = PL_curstackinfo; + + for (;;) { + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); + } + if (cxix < 0) + return NULL; + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && + ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) + count++; + if (!count--) + break; + cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + } + + cx = &ccstack[cxix]; + if (dbcxp) *dbcxp = cx; + + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the + field below is defined for any cx. */ + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) + cx = &ccstack[dbcxix]; + } + + return cx; +} + +# endif +#endif /* caller_cx */ +#endif /* 5.6.0 */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +UV +DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +UV +DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +UV +DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%" UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%" UVxf "}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/stacksize b/stacksize new file mode 100644 index 0000000..7abd3a8 --- /dev/null +++ b/stacksize @@ -0,0 +1,232 @@ +#!/usr/bin/perl +# binary search maximum stack depth for arrays and hashes +# and store it in lib/Storable/Limit.pm + +use Config; +use Cwd; +use File::Spec; +use strict; + +my $fn = "lib/Storable/Limit.pm"; +my $ptrsize = $Config{ptrsize}; +my ($bad1, $bad2) = (65001, 25000); +sub QUIET () { + (defined $ENV{MAKEFLAGS} and $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/ + and !defined($ENV{TRAVIS})) + ? 1 : 0 +} +sub PARALLEL () { + if (defined $ENV{MAKEFLAGS} + and $ENV{MAKEFLAGS} =~ /\bj\s*(\d+)\b/ + and $1 > 1) { + return 1; + } else { + return 0; + } +} +sub is_miniperl { + return !defined &DynaLoader::boot_DynaLoader; +} + +if (is_miniperl()) { + die "Should not run during miniperl\n"; +} +my $prefix = ""; +if ($^O eq "MSWin32") { + # prevent Windows popping up a dialog each time we overflow + # the stack + require Win32API::File; + Win32API::File->import(qw(SetErrorMode SEM_NOGPFAULTERRORBOX SEM_FAILCRITICALERRORS)); + SetErrorMode(SEM_NOGPFAULTERRORBOX() | SEM_FAILCRITICALERRORS()); +} +# the ; here is to ensure system() passes this to the shell +elsif (system("ulimit -c 0 ;") == 0) { + # try to prevent core dumps + $prefix = "ulimit -c 0 ; "; +} +if (@ARGV and $ARGV[0] eq '--core') { + $ENV{PERL_CORE} = 1; +} +my $PERL = $^X; +if ($ENV{PERL_CORE}) { + my $path; + my $ldlib = $Config{ldlibpthname}; + if (-d 'dist/Storable') { + chdir 'dist/Storable'; + $PERL = "../../$PERL" unless $PERL =~ m|^/|; + } + if ($ldlib) { + $path = getcwd()."/../.."; + } + if ($^O eq 'MSWin32' and -d '../dist/Storable') { + chdir '..\dist\Storable'; + $PERL = "..\\..\\$PERL" unless $PERL =~ /^[A-Za-z]:\\/; + } + $PERL = "\"$PERL\"" if $PERL =~ / /; + if ($ldlib and $ldlib ne 'PATH') { + $PERL = "$ldlib=$path $PERL"; + } +} + +-d "lib" or mkdir "lib"; +-d "lib/Storable" or mkdir "lib/Storable"; + +if ($^O eq "MSWin32") { + require Win32; + my ($str, $major, $minor) = Win32::GetOSVersion(); + if ($major < 6 || $major == 6 && $minor < 1) { + print "Using defaults for older Win32\n"; + write_limits(500, 256); + exit; + } +} +my ($n, $good, $bad, $found) = + (65000, 100, $bad1, undef); +print "probe for max. stack sizes...\n" unless QUIET; +# -I. since we're run before pm_to_blib (which is going to copy the +# file we create) and need to load our Storable.pm, not the already +# installed Storable.pm +my $mblib = '-Mblib -I.'; +if ($ENV{PERL_CORE}) { + if ($^O eq 'MSWin32') { + $mblib = '-I..\..\lib\auto -I..\..\lib'; + } else { + $mblib = '-I../../lib/auto -I../../lib'; + } +} +if (PARALLEL) { + # problem with parallel builds. wait for INST_DYNAMIC linking to be done. + # the problem is the RM_F INST_DYNAMIC race. + print "parallel build race - wait for linker ...\n" unless QUIET; + sleep(2.0); +} + +sub cmd { + my ($i, $try, $limit_name) = @_; + die unless $i; + my $code = "my \$t; \$Storable::$limit_name = -1; $try for 1..$i;dclone(\$t); print qq/ok\n/"; + my $q = ($^O eq 'MSWin32') ? '"' : "'"; + + "$prefix $PERL $mblib -MStorable=dclone -e$q$code$q" +} +# try more +sub good { + my $i = shift; # this passed + my $j = $i + abs(int(($bad - $i) / 2)); + print "Storable: determining recursion limit: $i passed, try more $j ...\n" unless QUIET; + $good = $i; + if ($j <= $i) { + $found++; + } + return $j; +} +# try less +sub bad { + my $i = shift; # this failed + my $j = $i - abs(int(($i - $good) / 2)); + print "Storable: determining recursion limit: $i too big, try less $j ...\n" unless QUIET; + $bad = $i; + if ($j >= $i) { + $j = $good; + $found++; + } + return $j; +} + +sub array_cmd { + my $depth = shift; + return cmd($depth, '$t=[$t]', 'recursion_limit'); +} + +# first check we can successfully run with a minimum level +my $cmd = array_cmd(1); +unless ((my $output = `$cmd`) =~ /\bok\b/) { + die "Cannot run probe: '$output', aborting...\n"; +} + +unless ($ENV{STORABLE_NOISY}) { + # suppress Segmentation fault messages + open STDERR, ">", File::Spec->devnull; +} + +while (!$found) { + my $cmd = array_cmd($n); + #print "$cmd\n" unless $QUIET; + if (`$cmd` =~ /\bok\b/) { + $n = good($n); + } else { + $n = bad($n); + } +} +print "MAX_DEPTH = $n\n" unless QUIET; +my $max_depth = $n; + +($n, $good, $bad, $found) = + (int($n/2), 50, $n, undef); +# pack j only since 5.8 +my $max = ($] > 5.007 and length(pack "j", 0) < 8) + ? ($^O eq 'MSWin32' ? 3000 : 8000) + : $max_depth; +$n = $max if $n > $max; +$bad = $max if $bad > $max; +while (!$found) { + my $cmd = cmd($n, '$t={1=>$t}', 'recursion_limit_hash'); + #print "$cmd\n" unless $QUIET; + if (`$cmd` =~ /\bok\b/) { + $n = good($n); + } else { + $n = bad($n); + } +} +if ($max_depth == $bad1-1 + and $n == $bad2-1) +{ + # more likely the shell. travis docker ubuntu, mingw e.g. + print "Error: Apparently your system(SHELLSTRING) cannot catch stack overflows\n" + unless QUIET; + $max_depth = 512; + $n = 256; + print "MAX_DEPTH = $max_depth\n" unless QUIET; +} +print "MAX_DEPTH_HASH = $n\n" unless QUIET; +my $max_depth_hash = $n; + +# Previously this calculation was done in the macro, calculate it here +# instead so a user setting of either variable more closely matches +# the limits the use sees. + +# be fairly aggressive in trimming this, smoke testing showed several +# several apparently random failures here, eg. working in one +# configuration, but not in a very similar configuration. +$max_depth = int(0.6 * $max_depth); +$max_depth_hash = int(0.6 * $max_depth); + +my $stack_reserve = $^O eq "MSWin32" ? 32 : 16; +if ($] ge "5.016" && !($^O eq "cygwin" && $ptrsize == 8)) { + $max_depth -= $stack_reserve; + $max_depth_hash -= $stack_reserve; +} +else { + # within the exception we need another stack depth to recursively + # cleanup the hash + $max_depth = ($max_depth >> 1) - $stack_reserve; + $max_depth_hash = ($max_depth_hash >> 1) - $stack_reserve * 2; +} + +write_limits($max_depth, $max_depth_hash); + +sub write_limits { + my ($max_depth, $max_depth_hash) = @_; + my $f; + open $f, ">", $fn or die "$fn $!"; + print $f < 1; + +# this original worked with the packaged exploit, but that +# triggers virus scanners, so test for the behaviour instead +my $x = bless \(my $y = "mt-config.cgi"), "CGITempFile"; + +my $frozen = freeze($x); + +{ + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= "@_" }; + thaw($frozen); + like($warnings, qr/SECURITY: Movable-Type CVE-2015-1592 Storable metasploit attack/, + 'Detect CVE-2015-1592'); +} diff --git a/t/HAS_ATTACH.pm b/t/HAS_ATTACH.pm new file mode 100644 index 0000000..72855aa --- /dev/null +++ b/t/HAS_ATTACH.pm @@ -0,0 +1,10 @@ +package HAS_ATTACH; + +sub STORABLE_attach { + ++$attached_count; + return bless [], 'HAS_ATTACH'; +} + +++$loaded_count; + +1; diff --git a/t/HAS_HOOK.pm b/t/HAS_HOOK.pm new file mode 100644 index 0000000..979a6a2 --- /dev/null +++ b/t/HAS_HOOK.pm @@ -0,0 +1,9 @@ +package HAS_HOOK; + +sub STORABLE_thaw { + ++$thawed_count; +} + +++$loaded_count; + +1; diff --git a/t/HAS_OVERLOAD.pm b/t/HAS_OVERLOAD.pm new file mode 100644 index 0000000..8a622a4 --- /dev/null +++ b/t/HAS_OVERLOAD.pm @@ -0,0 +1,14 @@ +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/t/attach.t b/t/attach.t new file mode 100644 index 0000000..5ffdae5 --- /dev/null +++ b/t/attach.t @@ -0,0 +1,42 @@ +#!./perl -w +# +# This file tests that Storable correctly uses STORABLE_attach hooks + +sub BEGIN { + unshift @INC, 't'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 => 3; +use Storable (); + +{ + my $destruct_cnt = 0; + my $obj = bless {data => 'ok'}, 'My::WithDestructor'; + my $target = Storable::thaw( Storable::freeze( $obj ) ); + is( $target->{data}, 'ok', 'We got correct object after freeze/thaw' ); + is( $destruct_cnt, 0, 'No tmp objects created by Storable' ); + undef $obj; + undef $target; + is( $destruct_cnt, 2, 'Only right objects destroyed at the end' ); + + package My::WithDestructor; + + sub STORABLE_freeze { + my ($self, $clone) = @_; + return $self->{data}; + } + + sub STORABLE_attach { + my ($class, $clone, $string) = @_; + return bless {data => $string}, 'My::WithDestructor'; + } + + sub DESTROY { $destruct_cnt++; } +} + diff --git a/t/attach_errors.t b/t/attach_errors.t new file mode 100644 index 0000000..0ed7c8d --- /dev/null +++ b/t/attach_errors.t @@ -0,0 +1,296 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 => 40; +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 reference' ); + # 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'; + } +} + +# Good case - multiple references to the same object should be attached properly +{ + my $obj = bless { id => 111 }, 'My::GoodAttach::MultipleReferences'; + my $arr = [$obj]; + + push @$arr, $obj; + + my $frozen = Storable::freeze($arr); + + ok( $frozen, 'My::GoodAttach return as expected' ); + + my $thawed = eval { + Storable::thaw( $frozen ); + }; + + isa_ok( $thawed->[0], 'My::GoodAttach::MultipleReferences' ); + isa_ok( $thawed->[1], 'My::GoodAttach::MultipleReferences' ); + + is($thawed->[0], $thawed->[1], 'References to the same object are attached properly'); + is($thawed->[1]{id}, $obj->{id}, 'Object with multiple references attached properly'); + + package My::GoodAttach::MultipleReferences; + + sub STORABLE_freeze { + my ($obj) = @_; + $obj->{id} + } + + sub STORABLE_attach { + my ($class, $cloning, $id) = @_; + bless { id => $id }, $class; + } + +} + + + +# 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/t/attach_singleton.t b/t/attach_singleton.t new file mode 100644 index 0000000..c555c5c --- /dev/null +++ b/t/attach_singleton.t @@ -0,0 +1,90 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 => 16; +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 confirms correct behaviour' ); + +$struct = [ $object, $object ]; +$frozen = Storable::freeze($struct); +$thawed = Storable::thaw($frozen); +is("$thawed->[0]", "$thawed->[1]", "Multiple Singletons thaw correctly"); + +# 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/t/blessed.t b/t/blessed.t new file mode 100644 index 0000000..d9a77b3 --- /dev/null +++ b/t/blessed.t @@ -0,0 +1,416 @@ +#!./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 { + # Do this as the very first thing, in order to avoid problems with the + # PADTMP flag on pre-5.19.3 threaded Perls. On those Perls, compiling + # code that contains a constant-folded canonical truth value breaks + # the ability to take a reference to that canonical truth value later. + $::false = 0; + %::immortals = ( + 'u' => \undef, + 'y' => \!$::false, + 'n' => \!!$::false, + ); +} + +sub BEGIN { + if ($ENV{PERL_CORE}) { + chdir 'dist/Storable' if -d 'dist/Storable'; + @INC = ('../../lib', 't'); + } else { + unshift @INC, 't'; + unshift @INC, 't/compat' if $] < 5.006002; + } + 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(freeze thaw store retrieve fd_retrieve); + +%::weird_refs = + (REF => \(my $aref = []), + VSTRING => \(my $vstring = v1.2.3), + 'long VSTRING' => \(my $lvstring = eval "v" . 0 x 300), + LVALUE => \(my $substr = substr((my $str = "foo"), 0, 3))); + +my $test = 13; +my $tests = $test + 41 + (2 * 6 * keys %::immortals) + (3 * keys %::weird_refs); +plan(tests => $tests); + +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 +# Identifier too long - 5.004 +# parser.h: char tokenbuf[256]: cperl5.24 => 1024 +my $m = ($Config{usecperl} and $] >= 5.024) ? 56 : 14; +my $longname = "LONG_NAME_" . ('xxxxxxxxxxxxx::' x $m) . "final"; + +eval <make); + push(@pool, SHORT_NAME_WITH_HOOK->make); + push(@pool, $longname->make); + push(@pool, "${longname}_WITH_HOOK"->make); +} + +my $x = freeze \@pool; +pass("Freeze didn't crash"); + +my $y = thaw $x; +is(ref $y, 'ARRAY'); +is(scalar @{$y}, @pool); + +is(ref $y->[0], 'SHORT_NAME'); +is(ref $y->[1], 'SHORT_NAME_WITH_HOOK'); +is(ref $y->[2], $longname); +is(ref $y->[3], "${longname}_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 $longname; + do { $good = 0; last } unless ref $y->[4*$i+3] eq "${longname}_WITH_HOOK"; +} +is($good, 1); + +{ + my $blessed_ref = bless \\[1,2,3], 'Foobar'; + my $x = freeze $blessed_ref; + my $y = thaw $x; + is(ref $y, 'Foobar'); + is($$$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::is(scalar @refs, $times); + my $expect = $::immortals{$what}; + die "'$x' did not give a reference" unless ref $expect; + my $fail; + foreach (@refs) { + $fail++ if $_ != $expect; + } + main::is($fail, undef); +} + +package main; + +# XXX Failed tests: 15, 27, 39 with 5.12 and 5.10 threaded. +# 15: 1 fail (y x 1), 27: 2 fail (y x 2), 39: 3 fail (y x 3) +# $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); + TODO: { + # ref sv_true is not always sv_true, at least in older threaded perls. + local $TODO = "Some 5.10/12 do not preserve ref identity with freeze \\(1 == 1)" + if !defined($f) and $] < 5.013 and $] > 5.009 and $immortal eq 'y'; + isnt($f, undef); + } + my $t = thaw $f; + pass("thaw didn't crash"); + } +} + +# 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); + +is($HAS_HOOK::loaded_count, 0); +is($HAS_HOOK::thawed_count, 0); + +my $t = thaw $f; +is($HAS_HOOK::loaded_count, 1); +is($HAS_HOOK::thawed_count, 1); +isnt($t, undef); +is(ref $t, 'HAS_HOOK'); + +delete $INC{"HAS_HOOK.pm"}; +delete $HAS_HOOK::{STORABLE_thaw}; + +$t = thaw $f; +is($HAS_HOOK::loaded_count, 2); +is($HAS_HOOK::thawed_count, 2); +isnt($t, undef); +is(ref $t, 'HAS_HOOK'); + +{ + package STRESS_THE_STACK; + + my $stress; + sub make { + bless []; + } + + sub no_op { + 0; + } + + sub STORABLE_freeze { + my $self = shift; + ++$freeze_count; + return no_op(1..(++$stress * 2000)) ? die "can't happen" : ''; + } + + sub STORABLE_thaw { + my $self = shift; + ++$thaw_count; + no_op(1..(++$stress * 2000)) && die "can't happen"; + return; + } +} + +$STRESS_THE_STACK::freeze_count = 0; +$STRESS_THE_STACK::thaw_count = 0; + +$f = freeze (STRESS_THE_STACK->make); + +is($STRESS_THE_STACK::freeze_count, 1); +is($STRESS_THE_STACK::thaw_count, 0); + +$t = thaw $f; +is($STRESS_THE_STACK::freeze_count, 1); +is($STRESS_THE_STACK::thaw_count, 1); +isnt($t, undef); +is(ref $t, 'STRESS_THE_STACK'); + +my $file = "storable-testfile.$$"; +die "Temporary file '$file' already exists" if -e $file; + +END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} + +$STRESS_THE_STACK::freeze_count = 0; +$STRESS_THE_STACK::thaw_count = 0; + +store (STRESS_THE_STACK->make, $file); + +is($STRESS_THE_STACK::freeze_count, 1); +is($STRESS_THE_STACK::thaw_count, 0); + +$t = retrieve ($file); +is($STRESS_THE_STACK::freeze_count, 1); +is($STRESS_THE_STACK::thaw_count, 1); +isnt($t, undef); +is(ref $t, 'STRESS_THE_STACK'); + +{ + package ModifyARG112358; + sub STORABLE_freeze { $_[0] = "foo"; } + my $o= {str=>bless {}}; + my $f= ::freeze($o); + ::is ref $o->{str}, __PACKAGE__, + 'assignment to $_[0] in STORABLE_freeze does not corrupt things'; +} + +# [perl #113880] +{ + { + package WeirdRefHook; + sub STORABLE_freeze { () } + $INC{'WeirdRefHook.pm'} = __FILE__; + } + + for my $weird (keys %weird_refs) { + my $obj = $weird_refs{$weird}; + bless $obj, 'WeirdRefHook'; + my $frozen; + my $success = eval { $frozen = freeze($obj); 1 }; + ok($success, "can freeze $weird objects") + || diag("freezing failed: $@"); + my $thawn = thaw($frozen); + # is_deeply ignores blessings + is ref $thawn, ref $obj, "get the right blessing back for $weird"; + if ($weird =~ 'VSTRING') { + # It is not just Storable that did not support vstrings. :-) + # See https://rt.cpan.org/Ticket/Display.html?id=78678 + my $newver = "version"->can("new") + ? sub { "version"->new(shift) } + : sub { "" }; + if (!ok + $$thawn eq $$obj && &$newver($$thawn) eq &$newver($$obj), + "get the right value back" + ) { + diag "$$thawn vs $$obj"; + diag &$newver($$thawn) eq &$newver($$obj) if &$newver(1); + } + } + else { + is_deeply($thawn, $obj, "get the right value back"); + } + } +} + +{ + # [perl #118551] + { + package RT118551; + + sub new { + my $class = shift; + my $string = shift; + die 'Bad data' unless defined $string; + my $self = { string => $string }; + return bless $self, $class; + } + + sub STORABLE_freeze { + my $self = shift; + my $cloning = shift; + return if $cloning; + return ($self->{string}); + } + + sub STORABLE_attach { + my $class = shift; + my $cloning = shift; + my $string = shift; + return $class->new($string); + } + } + + my $x = [ RT118551->new('a'), RT118551->new('') ]; + + $y = freeze($x); + + ok(eval {thaw($y)}, "empty serialized") or diag $@; # <-- dies here with "Bad data" +} + +{ + { + package FreezeHookDies; + sub STORABLE_freeze { + die ${$_[0]} + } + + package ThawHookDies; + sub STORABLE_freeze { + my ($self, $cloning) = @_; + my $tmp = $$self; + return "a", \$tmp; + } + sub STORABLE_thaw { + my ($self, $cloning, $str, $obj) = @_; + die $$obj; + } + } + my $x = bless \(my $tmpx = "Foo"), "FreezeHookDies"; + my $y = bless \(my $tmpy = []), "FreezeHookDies"; + + ok(!eval { store($x, "store$$"); 1 }, "store of hook which throws no NL died"); + ok(!eval { store($y, "store$$"); 1 }, "store of hook which throws ref died"); + + ok(!eval { freeze($x); 1 }, "freeze of hook which throws no NL died"); + ok(!eval { freeze($y); 1 }, "freeze of hook which throws ref died"); + + ok(!eval { dclone($x); 1 }, "dclone of hook which throws no NL died"); + ok(!eval { dclone($y); 1 }, "dclone of hook which throws ref died"); + + my $ostr = bless \(my $tmpstr = "Foo"), "ThawHookDies"; + my $oref = bless \(my $tmpref = []), "ThawHookDies"; + ok(store($ostr, "store$$"), "save throw Foo on thaw"); + ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw Foo on thaw died"); + open FH, "<", "store$$" or die; + binmode FH; + ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw Foo on thaw died"); + ok(!ref $@, "right thing thrown"); + close FH; + ok(store($oref, "store$$"), "save throw ref on thaw"); + ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw ref on thaw died"); + open FH, "<", "store$$" or die; + binmode FH; + ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw [] on thaw died"); + ok(ref $@, "right thing thrown"); + close FH; + + my $strdata = freeze($ostr); + ok(!eval { thaw($strdata); 1 }, "thaw of throw Foo on thaw died"); + ok(!ref $@, "and a string thrown"); + my $refdata = freeze($oref); + ok(!eval { thaw($refdata); 1 }, "thaw of throw [] on thaw died"); + ok(ref $@, "and a ref thrown"); + + unlink("store$$"); +} diff --git a/t/canonical.t b/t/canonical.t new file mode 100644 index 0000000..f7791ce --- /dev/null +++ b/t/canonical.t @@ -0,0 +1,139 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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); +our ($debugging, $verbose); + +use Test::More tests => 8; + +# Uncomment the following 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 Digest::MD5 if its available to make random string keys + +eval { require Digest::MD5; }; +$gotmd5 = !$@; +diag "Will use Digest::MD5" if $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 = Digest::MD5::md5_hex($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); + +cmp_ok(length $x1, '>', $hashsize); # sanity check +is(length $x1, length $x2); # idem +is($x1, $x2); +is($x1, $x3); + +# In normal mode it is exceedingly unlikely that the frozen +# representations 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(($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}; +is($$hash{''}[0], \$$hash{a}); + +my $cloned = dclone(dclone($hash)); +is($$cloned{''}[0], \$$cloned{a}); + +$$cloned{a} = "blah"; +is($$cloned{''}[0], \$$cloned{a}); diff --git a/t/circular_hook.t b/t/circular_hook.t new file mode 100644 index 0000000..fd635c0 --- /dev/null +++ b/t/circular_hook.t @@ -0,0 +1,87 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 circulars, 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/t/code.t b/t/code.t new file mode 100644 index 0000000..b4e7081 --- /dev/null +++ b/t/code.t @@ -0,0 +1,319 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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; + 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 => 63 } + +use Storable qw(retrieve store nstore freeze nfreeze thaw dclone); +use Safe; + +#$Storable::DEBUGME = 1; + +our ($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" }, + \&Storable::_store, # 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; + +is($thawed->[0]->(), "JAPH"); +is($thawed->[1]->(), 42); +is($thawed->[2]->(), "blessed"); +is($thawed->[3]->(), "Another::Package"); +is(prototype($thawed->[4]), prototype($obj[0]->[4])); + +###################################################################### + +$freezed = freeze $obj[1]; +$thawed = thaw $freezed; + +is($thawed->{"a"}->(), "srt"); +is($thawed->{"b"}->(), "JAPH"); + +###################################################################### + +$freezed = freeze $obj[2]; +$thawed = thaw $freezed; + +is($thawed->(), (ord "A") == 193 ? -118 : 42); + +###################################################################### + +$freezed = freeze $obj[3]; +$thawed = thaw $freezed; + +is($thawed->(), "JAPH"); + +###################################################################### + +eval { $freezed = freeze $obj[4] }; +like($@, qr/The result of B::Deparse::coderef2text was empty/); + +###################################################################### +# Test dclone + +my $new_sub = dclone($obj[2]); +is($new_sub->(), $obj[2]->()); + +###################################################################### +# Test retrieve & store + +store $obj[0], "store$$"; +# $Storable::DEBUGME = 1; +$thawed = retrieve "store$$"; + +is($thawed->[0]->(), "JAPH"); +is($thawed->[1]->(), 42); +is($thawed->[2]->(), "blessed"); +is($thawed->[3]->(), "Another::Package"); +is(prototype($thawed->[4]), prototype($obj[0]->[4])); + +###################################################################### + +nstore $obj[0], "store$$"; +$thawed = retrieve "store$$"; +unlink "store$$"; + +is($thawed->[0]->(), "JAPH"); +is($thawed->[1]->(), 42); +is($thawed->[2]->(), "blessed"); +is($thawed->[3]->(), "Another::Package"); +is(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 }; + like($@, qr/Can\'t eval/); + } +} + +{ + + local $Storable::Deparse = 0; + for my $i (0 .. 1) { + $@ = ""; + eval { $freezed = freeze $obj[$i] }; + like($@, 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 }; + is($@, ""); + like($$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"); + + is($@, ""); + isnt($freezed, ''); +} + +{ + my $safe = new Safe; + local $Storable::Eval = sub { $safe->reval(shift) }; + + $freezed = freeze $obj[0]->[0]; + $@ = ""; + eval { $thawed = thaw $freezed }; + is($@, ""); + is($thawed->(), "JAPH"); + + $freezed = freeze $obj[0]->[6]; + eval { $thawed = thaw $freezed }; + # The "Code sub ..." error message only appears if Log::Agent is installed + like($@, 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 }; + like($@, 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 }; + is($@, ""); + is($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 }; + is($@, ""); + + if ($@ ne "") { + fail() for (1..5); + } else { + is($thawed->[0]->(), "JAPH"); + is($thawed->[1]->(), 42); + is($thawed->[2]->(), "blessed"); + is($thawed->[3]->(), "Another::Package"); + is(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]; + is(int($res->[0]), int($res->[1])); + + $res = thaw freeze [$sclr, $sub, $sub, $sclr]; + is(int($res->[0]), int($res->[3])); + is(int($res->[1]), int($res->[2])); + + $res = thaw freeze [$sub, $sub, $sclr, $sclr]; + is(int($res->[0]), int($res->[1])); + is(int($res->[2]), int($res->[3])); + } + +} + +{ + my @text = ("hello", "\x{a3}", "\x{a3} \x{2234}", "\x{2234}\x{2234}"); + + for my $text(@text) { + my $res = (thaw freeze eval "sub {'" . $text . "'}")->(); + ok($res eq $text); + } +} + diff --git a/t/compat01.t b/t/compat01.t new file mode 100644 index 0000000..56d7df6 --- /dev/null +++ b/t/compat01.t @@ -0,0 +1,47 @@ +#!perl -w + +BEGIN { + unshift @INC, 't'; + unshift @INC, 't/compat' if $] < 5.006002; + 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); +use Test::More; + +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 +); + +plan(tests => 3 * @dumps); + +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: $!"; + + my $data = eval { retrieve($file) }; + is($@, '', "No errors for $file"); + is(ref $data, 'HASH', "Got HASH for $file"); + is($data->{one}, 1, "Got data for $file"); + + unlink($file); +} diff --git a/t/compat06.t b/t/compat06.t new file mode 100644 index 0000000..f8446ee --- /dev/null +++ b/t/compat06.t @@ -0,0 +1,144 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 => 8; + +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 () { + next if /^#/; + $data .= unpack("u", $_); + } +} else { + while () { + 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; +is(length $data, $expected_length); + +my $y = thaw($data); +isnt($y, undef); +is(ref $y, '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; +is(nfreeze($y), nfreeze($r)); + +is($y->ref->{key1}, 'val1'); +is($y->ref->{key2}, 'val2'); +is($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]; +} +is($ok, 1); + +__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-Tmake)); +# 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/t/croak.t b/t/croak.t new file mode 100644 index 0000000..ecd2bf8 --- /dev/null +++ b/t/croak.t @@ -0,0 +1,38 @@ +#!./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/t/dclone.t b/t/dclone.t new file mode 100644 index 0000000..ce6c756 --- /dev/null +++ b/t/dclone.t @@ -0,0 +1,99 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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); + +use Test::More tests => 14; + +$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); + +my $aref = dclone(\@a); +isnt($aref, undef); + +$dumped = &dump(\@a); +isnt($dumped, undef); + +$got = &dump($aref); +isnt($got, undef); + +is($got, $dumped); + +package FOO; @ISA = qw(Storable); + +sub make { + my $self = bless {}; + $self->{key} = \%main::a; + return $self; +}; + +package main; + +$foo = FOO->make; +my $r = $foo->dclone; +isnt($r, undef); + +is(&dump($foo), &dump($r)); + +# Ensure refs to "undef" values are properly shared during cloning +my $hash; +push @{$$hash{''}}, \$$hash{a}; +is($$hash{''}[0], \$$hash{a}); + +my $cloned = dclone(dclone($hash)); +is($$cloned{''}[0], \$$cloned{a}); + +$$cloned{a} = "blah"; +is($$cloned{''}[0], \$$cloned{a}); + +# [ID 20020221.007 (#8624)] 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. +is(ref $clone, ref $empty_string_obj); +is($$clone, $$empty_string_obj); +is($$clone, ''); + + +SKIP: { +# Do not fail if Tie::Hash and/or Tie::StdHash is not available + skip 'No Tie::StdHash available', 2 + unless eval { require Tie::Hash; scalar keys %Tie::StdHash:: }; + skip 'This version of perl has problems with Tie::StdHash', 2 + if $] eq "5.008"; + 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}; + is("@$clone_array", "@{$tie{array}}"); + my $clone_hash = dclone $tie{hash}; + is($clone_hash->{1}, $tie{hash}{1}); +} diff --git a/t/destroy.t b/t/destroy.t new file mode 100644 index 0000000..dcc3600 --- /dev/null +++ b/t/destroy.t @@ -0,0 +1,20 @@ +# [perl #118139] crash in global destruction when accessing the freed cxt. +use Test::More tests => 1; +use Storable; +BEGIN { + store {}, "foo"; +} +package foo; +sub new { return bless {} } +DESTROY { + open FH, '<', "foo" or die $!; + eval { Storable::pretrieve(*FH); }; + close FH or die $!; + unlink "foo"; +} + +package main; +# print "# $^X\n"; +$x = foo->new(); + +ok(1); diff --git a/t/downgrade.t b/t/downgrade.t new file mode 100644 index 0000000..617fb59 --- /dev/null +++ b/t/downgrade.t @@ -0,0 +1,507 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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; +our (%U_HASH, $UTF8_CROAK, $RESTRICTED_CROAK); + +our @RESTRICT_TESTS = ('Locked hash', 'Locked hash placeholder', + 'Locked keys', 'Locked keys placeholder', + ); +our %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 () { + 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. 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-dependencies 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 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 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 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 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````%%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.+#B$>CA8&D``````>#B$>C +FA8&D%P?B@XB3EHMS`@````;B@XB3EM\7!-QD) { + 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/t/flags.t b/t/flags.t new file mode 100644 index 0000000..e648f7a --- /dev/null +++ b/t/flags.t @@ -0,0 +1,103 @@ +#!./perl + +use Test::More tests => 16; + +use Storable (); + +use warnings; +use strict; + +package TEST; + +sub make { + my $pkg = shift; + return bless { a => 1, b => 2 }, $pkg; +} + +package TIED_HASH; + +sub TIEHASH { + my $pkg = shift; + return bless { a => 1, b => 2 }, $pkg; +} + +sub FETCH { + my ($self, $key) = @_; + return $self->{$key}; +} + +sub STORE { + my ($self, $key, $value) = @_; + $self->{$key} = $value; +} + +sub FIRSTKEY { + my $self = shift; + keys %$self; + return each %$self; +} + +sub NEXTKEY { + my $self = shift; + return each %{$self}; +} + +sub EXISTS { + my ($self, $key) = @_; + return exists $self->{$key}; +} + +package main; + +{ + my $obj = TEST->make; + + is_deeply($obj, { a => 1, b => 2 }, "object contains correct data"); + + my $frozen = Storable::freeze($obj); + my ($t1, $t2) = Storable::thaw($frozen); + + { + no warnings 'once'; + local $Storable::flags = Storable::FLAGS_COMPAT(); + $t2 = Storable::thaw($frozen); + } + + is_deeply($t1, $t2, "objects contain matching data"); + is(ref $t1, 'TEST', "default object is blessed"); + is(ref $t2, 'TEST', "compat object is blessed into correct class"); + + my $t3 = Storable::thaw($frozen, Storable::FLAGS_COMPAT()); + is_deeply($t2, $t3, "objects contain matching data (explicit test)"); + is(ref $t3, 'TEST', "compat object is blessed into correct class (explicit test)"); + + my $t4 = Storable::thaw($frozen, Storable::BLESS_OK()); + is_deeply($t2, $t3, "objects contain matching data (explicit test for bless)"); + is(ref $t3, 'TEST', "compat object is blessed into correct class (explicit test for bless)"); + + { + no warnings 'once'; + local $Storable::flags = Storable::FLAGS_COMPAT(); + my $t5 = Storable::thaw($frozen, 0); + my $t6 = Storable::thaw($frozen, Storable::TIE_OK()); + + is_deeply($t1, $t5, "objects contain matching data"); + is_deeply($t1, $t6, "objects contain matching data for TIE_OK"); + is(ref $t5, 'HASH', "default object is unblessed"); + is(ref $t6, 'HASH', "TIE_OK object is unblessed"); + } +} + +{ + tie my %hash, 'TIED_HASH'; + ok(tied %hash, "hash is tied"); + my $obj = { bow => \%hash }; + + my $frozen = Storable::freeze($obj); + my $t1 = Storable::thaw($frozen, Storable::FLAGS_COMPAT()); + my $t2 = eval { Storable::thaw($frozen); }; + + ok(!$@, "trying to thaw a tied value succeeds"); + ok(tied %{$t1->{bow}}, "compat object is tied"); + is(ref tied %{$t1->{bow}}, 'TIED_HASH', "compat object is tied into correct class"); +} diff --git a/t/forgive.t b/t/forgive.t new file mode 100644 index 0000000..1833a26 --- /dev/null +++ b/t/forgive.t @@ -0,0 +1,65 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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); +use Test::More; + +# 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) { + plan(skip_all => "File::Spec 0.8 needed"); + # Mention $File::Spec::VERSION again, as 5.00503's harness seems to have + # warnings on. + exit $File::Spec::VERSION; +} + +plan(tests => 8); + +*GLOB = *GLOB; # peacify -w +my $bad = ['foo', \*GLOB, 'bar']; +my $result; + +eval {$result = store ($bad , "store$$")}; +is($result, undef); +isnt($@, ''); + +$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"); + +isnt($result, undef); +is($@, ''); + +my $ret = retrieve("store$$"); +isnt($ret, undef); +is($ret->[0], 'foo'); +is($ret->[2], 'bar'); +is(ref $ret->[1], 'SCALAR'); + + +END { 1 while unlink "store$$" } diff --git a/t/freeze.t b/t/freeze.t new file mode 100644 index 0000000..d254c6f --- /dev/null +++ b/t/freeze.t @@ -0,0 +1,138 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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(freeze nfreeze thaw); + +$Storable::flags = Storable::FLAGS_COMPAT; + +use Test::More tests => 21; + +$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); + +my $f1 = freeze(\@a); +isnt($f1, undef); + +$dumped = &dump(\@a); +isnt($dumped, undef); + +$root = thaw($f1); +isnt($root, undef); + +$got = &dump($root); +isnt($got, undef); + +is($got, $dumped); + +package FOO; @ISA = qw(Storable); + +sub make { + my $self = bless {}; + $self->{key} = \%main::a; + return $self; +}; + +package main; + +$foo = FOO->make; +my $f2 = $foo->freeze; +isnt($f2, undef); + +my $f3 = $foo->nfreeze; +isnt($f3, undef); + +$root3 = thaw($f3); +isnt($root3, undef); + +is(&dump($foo), &dump($root3)); + +$root = thaw($f2); +is(&dump($foo), &dump($root)); + +is(&dump($root3), &dump($root)); + +$other = freeze($root); +is(length$other, length $f2); + +$root2 = thaw($other); +is(&dump($root2), &dump($root)); + +$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); +is($VAR2->[3], $VAR1->[3]); + +# 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) }; +is($@, ''); + +# Test cleanup bug found by Claudio Garcia -- RAM, 08/06/2001 +my $thaw_me = 'asdasdasdasd'; + +eval { + my $thawed = thaw $thaw_me; +}; +isnt($@, ''); + +my %to_be_frozen = (foo => 'bar'); +my $frozen; +eval { + $frozen = freeze \%to_be_frozen; +}; +is($@, ''); + +freeze {}; +eval { thaw $thaw_me }; +eval { $frozen = freeze { foo => {} } }; +is($@, ''); + +thaw $frozen; # used to segfault here +pass("Didn't segfault"); + +SKIP: { + skip 'no av_exists', 2 unless $] >= 5.006; + my (@a, @b); + eval ' + $a = []; $#$a = 2; $a->[1] = undef; + $b = thaw freeze $a; + @a = map { ~~ exists $a->[$_] } 0 .. $#$a; + @b = map { ~~ exists $b->[$_] } 0 .. $#$b; + '; + is($@, ''); + is("@a", "@b"); +} diff --git a/t/huge.t b/t/huge.t new file mode 100644 index 0000000..d28e238 --- /dev/null +++ b/t/huge.t @@ -0,0 +1,104 @@ +#!./perl + +use strict; +use warnings; + +use Config; +use Storable qw(dclone); +use Test::More; + +BEGIN { + plan skip_all => 'Storable was not built' + if $ENV{PERL_CORE} && $Config{'extensions'} !~ /\b Storable \b/x; + plan skip_all => 'Need 64-bit pointers for this test' + if $Config{ptrsize} < 8 and $] > 5.013; + plan skip_all => 'Need 64-bit int for this test on older versions' + if $Config{uvsize} < 8 and $] < 5.013; + plan skip_all => 'Need ~4 GiB memory for this test, set PERL_TEST_MEMORY > 4' + if !$ENV{PERL_TEST_MEMORY} || $ENV{PERL_TEST_MEMORY} < 4; +} + +# Just too big to fit in an I32. +my $huge = int(2 ** 31); +# v5.24.1c/v5.25.1c switched to die earlier with "Too many elements", +# which is much safer. +my $has_too_many = ($Config{usecperl} and + (($] >= 5.024001 and $] < 5.025000) + or $] >= 5.025001)) ? 1 : 0; + +# These overlarge sizes are enabled only since Storable 3.00 and some +# cases need cperl support. Perl5 (as of 5.24) has some internal +# problems with >I32 sizes, which only cperl has fixed. +# perl5 is not yet 2GB safe, esp. with hashes. + +# string len (xpv_cur): STRLEN (ptrsize>=8) +# array size (xav_max): SSize_t (I32/I64) (ptrsize>=8) +# hash size (xhv_keys): +# IV - 5.12 (ivsize>=8) +# STRLEN 5.14 - 5.24 (size_t: U32/U64) +# SSize_t 5.22c - 5.24c (I32/I64) +# U32 5.25c - +# hash key: I32 + +my @cases = ( + ['huge string', + sub { my $s = 'x' x $huge; \$s }], + + ['array with huge element', + sub { my $s = 'x' x $huge; [$s] }], + + ['hash with huge value', + sub { my $s = 'x' x $huge; +{ foo => $s } }], + + # There's no huge key, limited to I32. + ) if $Config{ptrsize} > 4; + + +# An array with a huge number of elements requires several gigabytes of +# virtual memory. On darwin it is evtl killed. +if ($Config{ptrsize} > 4 and !$has_too_many) { + # needs 20-55G virtual memory, 4.6M heap and several minutes on a fast machine + if ($ENV{PERL_TEST_MEMORY} >= 55) { + push @cases, + [ 'huge array', + sub { my @x; $x[$huge] = undef; \@x } ]; + } else { + diag "skip huge array, need PERL_TEST_MEMORY >= 8"; + } +} + +# A hash with a huge number of keys would require tens of gigabytes of +# memory, which doesn't seem like a good idea even for this test file. +# Unfortunately even older 32bit perls do allow this. +if (!$has_too_many) { + # needs >90G virtual mem, and is evtl. killed + if ($ENV{PERL_TEST_MEMORY} >= 96) { + # number of keys >I32. impossible to handle with perl5, but Storable can. + push @cases, + ['huge hash', + sub { my %x = (0 .. $huge); \%x } ]; + } else { + diag "skip huge hash, need PERL_TEST_MEMORY >= 16"; + } +} + + +plan tests => 2 * scalar @cases; + +for (@cases) { + my ($desc, $build) = @$_; + diag "building test input: $desc"; + my ($input, $exn, $clone); + diag "these huge subtests need a lot of memory and time!" if $desc eq 'huge array'; + $input = $build->(); + diag "running test: $desc"; + $exn = $@ if !eval { $clone = dclone($input); 1 }; + + is($exn, undef, "$desc no exception"); + is_deeply($input, $clone, "$desc cloned"); + #ok($clone, "$desc cloned"); + + # Ensure the huge objects are freed right now: + undef $input; + undef $clone; +} diff --git a/t/hugeids.t b/t/hugeids.t new file mode 100644 index 0000000..c0e19ae --- /dev/null +++ b/t/hugeids.t @@ -0,0 +1,372 @@ +#!./perl + +# We do all of the work in child processes here to ensure that any +# memory used is released immediately. + +# These tests use ridiculous amounts of memory and CPU. + +use strict; +use warnings; + +use Config; +use Storable qw(store_fd retrieve_fd nstore_fd); +use Test::More; +use File::Temp qw(tempfile); +use File::Spec; + +BEGIN { + plan skip_all => 'Storable was not built' + if $ENV{PERL_CORE} && $Config{'extensions'} !~ /\b Storable \b/x; + plan skip_all => 'Need 64-bit pointers for this test' + if $Config{ptrsize} < 8 and $] > 5.013; + plan skip_all => 'Need 64-bit int for this test on older versions' + if $Config{uvsize} < 8 and $] < 5.013; + plan skip_all => 'Need ~8 GiB memory for this test, set PERL_TEST_MEMORY >= 8' + if !$ENV{PERL_TEST_MEMORY} || $ENV{PERL_TEST_MEMORY} < 8; + plan skip_all => 'These tests are slow, set PERL_RUN_SLOW_TESTS' + unless $ENV{PERL_RUN_SLOW_TESTS}; + plan skip_all => "Need fork for this test", + unless $Config{d_fork}; +} + +find_exe("gzip") + or plan skip_all => "Need gzip for this test"; +find_exe("gunzip") + or plan skip_all => "Need gunzip for this test"; + +plan tests => 12; + +my $skips = $ENV{PERL_STORABLE_SKIP_ID_TEST} || ''; +my $keeps = $ENV{PERL_STORABLE_KEEP_ID_TEST}; + +freeze_thaw_test + ( + name => "object ids between 2G and 4G", + freeze => \&make_2g_data, + thaw => \&check_2g_data, + id => "2g", + memory => 34, + ); + +freeze_thaw_test + ( + name => "object ids over 4G", + freeze => \&make_4g_data, + thaw => \&check_4g_data, + id => "4g", + memory => 70, + ); + +freeze_thaw_test + ( + name => "hook object ids over 4G", + freeze => \&make_hook_data, + thaw => \&check_hook_data, + id => "hook4g", + memory => 70, + ); + +# not really an id test, but the infrastructure here makes tests +# easier +freeze_thaw_test + ( + name => "network store large PV", + freeze => \&make_net_large_pv, + thaw => \&check_net_large_pv, + id => "netlargepv", + memory => 8, + ); + +freeze_thaw_test + ( + name => "hook store with 2g data", + freeze => \&make_2g_hook_data, + thaw => \&check_2g_hook_data, + id => "hook2gdata", + memory => 4, + ); + +freeze_thaw_test + ( + name => "hook store with 4g data", + freeze => \&make_4g_hook_data, + thaw => \&check_4g_hook_data, + id => "hook4gdata", + memory => 8, + ); + +sub freeze_thaw_test { + my %opts = @_; + + my $freeze = $opts{freeze} + or die "Missing freeze"; + my $thaw = $opts{thaw} + or die "Missing thaw"; + my $id = $opts{id} + or die "Missing id"; + my $name = $opts{name} + or die "Missing name"; + my $memory = $opts{memory} + or die "Missing memory"; + my $todo_thaw = $opts{todo_thaw} || ""; + + SKIP: + { + # IPC::Run would be handy here + + $ENV{PERL_TEST_MEMORY} >= $memory + or skip "Not enough memory to test $name", 2; + $skips =~ /\b\Q$id\E\b/ + and skip "You requested test $name ($id) be skipped", 2; + defined $keeps && $keeps !~ /\b\Q$id\E\b/ + and skip "You didn't request test $name ($id)", 2; + my $stored; + if (defined(my $pid = open(my $fh, "-|"))) { + unless ($pid) { + # child + open my $cfh, "|-", "gzip" + or die "Cannot pipe to gzip: $!"; + binmode $cfh; + $freeze->($cfh); + exit; + } + # parent + $stored = do { local $/; <$fh> }; + close $fh; + } + else { + skip "$name: Cannot fork for freeze", 2; + } + ok($stored, "$name: we got output data") + or skip "$name: skipping thaw test", 1; + + my ($tfh, $tname) = tempfile(); + + #my $tname = "$id.store.gz"; + #open my $tfh, ">", $tname or die; + #binmode $tfh; + + print $tfh $stored; + close $tfh; + + if (defined(my $pid = open(my $fh, "-|"))) { + unless ($pid) { + # child + open my $bfh, "-|", "gunzip <$tname" + or die "Cannot pipe from gunzip: $!"; + binmode $bfh; + $thaw->($bfh); + exit; + } + my $out = do { local $/; <$fh> }; + chomp $out; + local $TODO = $todo_thaw; + is($out, "OK", "$name: check result"); + } + else { + skip "$name: Cannot fork for thaw", 1; + } + } +} + + +sub make_2g_data { + my ($fh) = @_; + my @x; + my $y = 1; + my $z = 2; + my $g2 = 0x80000000; + $x[0] = \$y; + $x[$g2] = \$y; + $x[$g2+1] = \$z; + $x[$g2+2] = \$z; + store_fd(\@x, $fh); +} + +sub check_2g_data { + my ($fh) = @_; + my $x = retrieve_fd($fh); + my $g2 = 0x80000000; + $x->[0] == $x->[$g2] + or die "First entry mismatch"; + $x->[$g2+1] == $x->[$g2+2] + or die "2G+ entry mismatch"; + print "OK"; +} + +sub make_4g_data { + my ($fh) = @_; + my @x; + my $y = 1; + my $z = 2; + my $g4 = 2*0x80000000; + $x[0] = \$y; + $x[$g4] = \$y; + $x[$g4+1] = \$z; + $x[$g4+2] = \$z; + store_fd(\@x, $fh); +} + +sub check_4g_data { + my ($fh) = @_; + my $x = retrieve_fd($fh); + my $g4 = 2*0x80000000; + $x->[0] == $x->[$g4] + or die "First entry mismatch"; + $x->[$g4+1] == $x->[$g4+2] + or die "4G+ entry mismatch"; + ${$x->[$g4+1]} == 2 + or die "Incorrect value in 4G+ entry"; + print "OK"; +} + +sub make_hook_data { + my ($fh) = @_; + my @x; + my $y = HookLargeIds->new(101, { name => "one" }); + my $z = HookLargeIds->new(201, { name => "two" }); + my $g4 = 2*0x8000_0000; + $x[0] = $y; + $x[$g4] = $y; + $x[$g4+1] = $z; + $x[$g4+2] = $z; + store_fd(\@x, $fh); +} + +sub check_hook_data { + my ($fh) = @_; + my $x = retrieve_fd($fh); + my $g4 = 2*0x8000_0000; + my $y = $x->[$g4+1]; + $y = $x->[$g4+1]; + $y->id == 201 + or die "Incorrect id in 4G+ object"; + ref($y->data) eq 'HASH' + or die "data isn't a ref"; + $y->data->{name} eq "two" + or die "data name not 'one'"; + print "OK"; +} + +sub make_net_large_pv { + my ($fh) = @_; + my $x = "x"; # avoid constant folding making a 4G scalar + my $g4 = 2*0x80000000; + my $y = $x x ($g4 + 5); + nstore_fd(\$y, $fh); +} + +sub check_net_large_pv { + my ($fh) = @_; + my $x = retrieve_fd($fh); + my $g4 = 2*0x80000000; + ref $x && ref($x) eq "SCALAR" + or die "Not a scalar ref ", ref $x; + + length($$x) == $g4+5 + or die "Incorect length"; + print "OK"; +} + +sub make_2g_hook_data { + my ($fh) = @_; + + my $g2 = 0x80000000; + my $x = HookLargeData->new($g2); + store_fd($x, $fh); +} + +sub check_2g_hook_data { + my ($fh) = @_; + my $x = retrieve_fd($fh); + my $g2 = 0x80000000; + $x->size == $g2 + or die "Size incorrect ", $x->size; + print "OK"; +} + +sub make_4g_hook_data { + my ($fh) = @_; + + my $g2 = 0x80000000; + my $g4 = 2 * $g2; + my $x = HookLargeData->new($g4+1); + store_fd($x, $fh); +} + +sub check_4g_hook_data { + my ($fh) = @_; + my $x = retrieve_fd($fh); + my $g2 = 0x80000000; + my $g4 = 2 * $g2; + $x->size == $g4+1 + or die "Size incorrect ", $x->size; + print "OK"; +} + +sub find_exe { + my ($exe) = @_; + + $exe .= $Config{_exe}; + my @path = split /\Q$Config{path_sep}/, $ENV{PATH}; + for my $dir (@path) { + my $abs = File::Spec->catfile($dir, $exe); + -x $abs + and return $abs; + } +} + +package HookLargeIds; + +sub new { + my $class = shift; + my ($id, $data) = @_; + return bless { id => $id, data => $data }, $class; +} + +sub STORABLE_freeze { + #print STDERR "freeze called\n"; + #Devel::Peek::Dump($_[0]); + + return $_[0]->id, $_[0]->data; +} + +sub STORABLE_thaw { + my ($self, $cloning, $ser, $data) = @_; + + #Devel::Peek::Dump(\@_); + #print STDERR "thaw called\n"; + #Devel::Peek::Dump($self); + $self->{id} = $ser+0; + $self->{data} = $data; +} + +sub id { + $_[0]{id}; +} + +sub data { + $_[0]{data}; +} + +package HookLargeData; + +sub new { + my ($class, $size) = @_; + + return bless { size => $size }, $class; +} + +sub STORABLE_freeze { + return "x" x $_[0]{size}; +} + +sub STORABLE_thaw { + my ($self, $cloning, $ser) = @_; + + $self->{size} = length $ser; +} + +sub size { + $_[0]{size}; +} diff --git a/t/integer.t b/t/integer.t new file mode 100644 index 0000000..b17f392 --- /dev/null +++ b/t/integer.t @@ -0,0 +1,178 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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/t/interwork56.t b/t/interwork56.t new file mode 100644 index 0000000..239c8c1 --- /dev/null +++ b/t/interwork56.t @@ -0,0 +1,196 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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; + +our (%tests); + +{ + local $/ = "\n\nend\n"; + while () { + 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 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]; + + is(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; + is(ref($oh_dear), "ARRAY", "dclone - circular overload"); + is($oh_dear->[0], "keep it so", "amagic ok 1"); + is($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; + is($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; + is(ref($oh_dear), "ARRAY", "dclone - after a closure dclone"); + is($oh_dear->[0], "keep it so", "amagic ok 1"); + is($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; + is(ref($oh_dear), "ARRAY", "dclone - before a closure dclone"); + is($oh_dear->[0], "keep it so", "amagic ok 1"); + is($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; + is(ref($oh_dear), "ARRAY", "dclone - between a closure dclone"); + is($oh_dear->[0], "keep it so", "amagic ok 1"); + is($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; + is(ref($oh_dear), "ARRAY", "dclone - after a closure dclone"); + is($oh_dear->[1], "keep it so", "amagic ok 1"); + is($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/t/leaks.t b/t/leaks.t new file mode 100644 index 0000000..eb151a1 --- /dev/null +++ b/t/leaks.t @@ -0,0 +1,49 @@ +#!./perl + +use Test::More; +use Storable (); +BEGIN { +eval "use Test::LeakTrace"; +plan 'skip_all' => 'Test::LeakTrace required for this tests' if $@; +} +plan 'tests' => 1; + +{ + my $c = My::Simple->new; + my $d; + my $freezed = Storable::freeze($c); + no_leaks_ok + { + $d = Storable::thaw($freezed); + undef $d; + }; + + package My::Simple; + sub new { + my ($class, $arg) = @_; + bless {t=>$arg}, $class; + } + sub STORABLE_freeze { + return "abcderfgh"; + } + sub STORABLE_attach { + my ($class, $c, $serialized) = @_; + return $class->new($serialized); + } +} + +{ # [cpan #97316] + package TestClass; + + sub new { + my $class = shift; + return bless({}, $class); + } + sub STORABLE_freeze { + die; + } + + package main; + my $obj = TestClass->new; + eval { freeze($obj); }; +} diff --git a/t/lock.t b/t/lock.t new file mode 100644 index 0000000..8c1fc57 --- /dev/null +++ b/t/lock.t @@ -0,0 +1,46 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 Test::More; +use Storable qw(lock_store lock_retrieve); + +unless (&Storable::CAN_FLOCK) { + plan(skip_all => "fcntl/flock emulation broken on this platform"); +} + +plan(tests => 5); + +@a = ('first', undef, 3, -4, -3.14159, 456, 4.5); + +# +# We're just ensuring things work, we're not validating locking. +# + +isnt(lock_store(\@a, "store$$"), undef); +my $dumped = &dump(\@a); +isnt($dumped, undef); + +$root = lock_retrieve("store$$"); +is(ref $root, 'ARRAY'); +is(scalar @a, scalar @$root); +is(&dump($root), $dumped); + +END { 1 while unlink "store$$" } + diff --git a/t/make_56_interwork.pl b/t/make_56_interwork.pl new file mode 100644 index 0000000..c73e9b6 --- /dev/null +++ b/t/make_56_interwork.pl @@ -0,0 +1,51 @@ +#!/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/t/make_downgrade.pl b/t/make_downgrade.pl new file mode 100644 index 0000000..fc801a4 --- /dev/null +++ b/t/make_downgrade.pl @@ -0,0 +1,106 @@ +#!/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/t/make_overload.pl b/t/make_overload.pl new file mode 100644 index 0000000..bd224f5 --- /dev/null +++ b/t/make_overload.pl @@ -0,0 +1,13 @@ +#!/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/t/malice.t b/t/malice.t new file mode 100644 index 0000000..5888863 --- /dev/null +++ b/t/malice.t @@ -0,0 +1,310 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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; + +our $byteorder = $Config{byteorder}; + +our $file_magic_str = 'pst0'; +our $other_magic = 7 + length $byteorder; +our $network_magic = 2; +our $major = 2; +our $minor = 11; +our $minor_write = $] >= 5.019 ? 11 : $] > 5.008 ? 9 : $] > 5.005_50 ? 8 : 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 +our $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'; +our $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); + local $Test::Builder::Level = $Test::Builder::Level + 1; + 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 + # Which we've now exhausted given that Storable 2.25 is writing 2.8 + # (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 $minor6 = $header->{minor} + 6; + substr ($copy, $file_magic + 1, 1) = chr $minor6; + { + # 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}\.$minor6 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 33 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 $minor6; + + # local $Storable::DEBUGME = 1; + # This is the delayed croak + test_corrupt ($copy, $sub, + "/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 33/", + "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}\.$minor6 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/t/overload.t b/t/overload.t new file mode 100644 index 0000000..64c09e4 --- /dev/null +++ b/t/overload.t @@ -0,0 +1,114 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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); + +$Storable::flags = Storable::FLAGS_COMPAT; + +use Test::More tests => 19; + +package OVERLOADED; + +use overload + '""' => sub { $_[0][0] }; + +package main; + +$a = bless [77], OVERLOADED; + +$b = thaw freeze $a; +is(ref $b, 'OVERLOADED'); +is("$b", "77"); + +$c = thaw freeze \$a; +is(ref $c, 'REF'); +is(ref $$c, 'OVERLOADED'); +is("$$c", "77"); + +$d = thaw freeze [$a, $a]; +is("$d->[0]", "77"); +$d->[0][0]++; +is("$d->[1]", "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; + +is(ref $b, 'OVER'); +is($a + $a, 314); +is(ref $b->{ref}, 'REF_TO_OVER'); +is("$b->{ref}->{over}", "$b"); +is($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 $@; +is($@, ""); +is(ref ($t), 'REF'); +is(ref ($$t), 'HAS_OVERLOAD'); +is($$$t, 'snow'); + + +#--- +# blessed reference to overloaded object. +{ + my $a = bless [88], 'OVERLOADED'; + my $c = thaw freeze bless \$a, 'main'; + is(ref $c, 'main'); + is(ref $$c, 'OVERLOADED'); + is("$$c", "88"); + +} + +1; diff --git a/t/recurse.t b/t/recurse.t new file mode 100644 index 0000000..fa8be0b --- /dev/null +++ b/t/recurse.t @@ -0,0 +1,368 @@ +#!./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. +# +use Config; + +sub BEGIN { + unshift @INC, 't'; + unshift @INC, 't/compat' if $] < 5.006002; + 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); + +$Storable::flags = Storable::FLAGS_COMPAT; + +use Test::More tests => 38; + +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; +isnt($x, undef); + +my $y = thaw $x; +is(ref $y, 'OBJ_REAL'); +is($y->[0], 'a'); +is($y->[1], 1); + +my $sync = OBJ_SYNC->make; +$x = freeze $sync; +isnt($x, undef); + +$y = thaw $x; +is(ref $y, 'OBJ_SYNC'); +is($y->{ok}, $y); + +my $ext = [1, 2]; +$sync = OBJ_SYNC2->make($ext); +$x = freeze [$sync, $ext]; +isnt($x, undef); + +my $z = thaw $x; +$y = $z->[0]; +is(ref $y, 'OBJ_SYNC2'); +is($y->{ok}, $y); +is(ref $y->{sync}, 'OBJ_SYNC'); +is($y->{ext}, $z->[1]); + +$real = OBJ_REAL2->make; +$x = freeze $real; +isnt($x, undef); +is($OBJ_REAL2::recursed, $OBJ_REAL2::MAX); +is($OBJ_REAL2::hook_called, $OBJ_REAL2::MAX); + +$y = thaw $x; +is(ref $y, 'OBJ_REAL2'); +is($OBJ_REAL2::recursed, 0); + +$x = dclone $real; +isnt($x, undef); +is(ref $x, 'OBJ_REAL2'); +is($OBJ_REAL2::recursed, 0); +is($OBJ_REAL2::hook_called, 2 * $OBJ_REAL2::MAX); + +is(Storable::is_storing, ''); +is(Storable::is_retrieving, ''); + +# +# The following was a test-case that Salvador Ortiz Garcia +# 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; + +is(ref($bar2), 'Bar'); +is(ref($bar->{b}[0]), 'Foo'); +is(ref($bar->{b}[1]), 'Foo'); +is(ref($bar2->{b}[0]), 'Foo'); +is(ref($bar2->{b}[1]), '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::is(ref $self, "CLASS_2"); + main::is(ref $c1, "CLASS_1"); + main::is(ref $c3, "CLASS_3"); + main::is(ref $o, "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 (#9436)] +# +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; + +my $o = CLASS_OTHER->make(); +my $c2 = CLASS_2->make($o); +my $so = thaw freeze $o; + +our $refcount_ok = 0; +thaw freeze(Foo3->new); +is($refcount_ok, 1, "check refcount"); + +# Check stack overflows [cpan #97526] +# JSON::XS limits this to 512. +# Small 64bit systems fail with 1200 (c++ debugging), with gcc 3000. +# Optimized 64bit allows up to 33.000 recursion depth. +# with asan the limit is 255 though. +sub MAX_DEPTH () { Storable::stack_depth() } +sub MAX_DEPTH_HASH () { Storable::stack_depth_hash() } +sub OVERFLOW () { 35000 } +{ + my $t; + print "# max depth ", MAX_DEPTH, "\n"; + $t = [$t] for 1 .. MAX_DEPTH; + dclone $t; + pass "can nest ".MAX_DEPTH." array refs"; +} +{ + my $t; + $t = {1=>$t} for 1 .. MAX_DEPTH_HASH-10; + dclone $t; + pass "can nest ".(MAX_DEPTH_HASH)." hash refs"; +} +{ + my (@t); + push @t, [{}] for 1..5000; + #diag 'trying simple array[5000] stack overflow, no recursion'; + dclone \@t; + is $@, '', 'No simple array[5000] stack overflow #257'; +} + +eval { + my $t; + $t = [$t] for 1 .. MAX_DEPTH*2; + note 'trying catching recursive aref stack overflow'; + dclone $t; +}; +like $@, qr/Max\. recursion depth with nested structures exceeded/, + 'Caught aref stack overflow '.MAX_DEPTH*2; + +if ($ENV{APPVEYOR} and length(pack "p", "") >= 8) { + # TODO: need to repro this fail on a small machine. + ok(1, "skip dclone of big hash"); +} +else { + eval { + my $t; + # 35.000 will cause appveyor 64bit windows to fail earlier + $t = {1=>$t} for 1 .. MAX_DEPTH * 2; + note 'trying catching recursive href stack overflow'; + dclone $t; + }; + like $@, qr/Max\. recursion depth with nested structures exceeded/, + 'Caught href stack overflow '.MAX_DEPTH*2; +} diff --git a/t/regexp.t b/t/regexp.t new file mode 100644 index 0000000..acf28cf --- /dev/null +++ b/t/regexp.t @@ -0,0 +1,127 @@ +#!perl -w +use strict; +use Storable "dclone"; +use Test::More; + +my $version = int(($]-5)*1000); + +$version >= 8 + or plan skip_all => "regexps not supported before 5.8"; + +my @tests; +while () { + chomp; + next if /^\s*#/ || !/\S/; + my ($range, $code, $match, $name) = split /\s*;\s*/; + defined $name or die "Bad test line"; + my $ascii_only = $range =~ s/A//; + next if $ascii_only and ord("A") != 65; + if ($range =~ /^(\d+)-$/) { + next if $version < $1 + } + elsif ($range =~ /^-(\d+)$/) { + next if $version > $1 + } + elsif ($range =~ /^(\d+)-(\d+)$/) { + next if $version < $1 || $version > $2; + } + elsif ($range ne "-") { + die "Invalid version range $range for $name"; + } + my @match = split /\s*,\s*/, $match; + for my $m (@match) { + my $not = $m =~ s/^!//; + my $cmatch = eval $m; + die if $@; + push @tests, [ $code, $not, $cmatch, $m, $name ]; + } +} + +plan tests => 9 + 3*scalar(@tests); + +SKIP: +{ + $version >= 14 && $version < 20 + or skip "p introduced in 5.14, pointless from 5.20", 4; + my $q1 = eval "qr/b/p"; + my $q2 = eval "qr/b/"; + my $c1 = dclone($q1); + my $c2 = dclone($q2); + ok("abc" =~ $c1, "abc matches $c1"); + is(${^PREMATCH}, "a", "check p worked"); + ok("cba" =~ $c2, "cba matches $c2"); + isnt(${^PREMATCH}, "c", "check no p worked"); +} + +SKIP: +{ + $version >= 24 + or skip "n introduced in 5.22", 4; + my $c1 = dclone(eval "qr/(\\w)/"); + my $c2 = dclone(eval "qr/(\\w)/n"); + ok("a" =~ $c1, "a matches $c1"); + is($1, "a", "check capturing preserved"); + ok("b" =~ $c2, "b matches $c2"); + isnt($1, "b", "check non-capturing preserved"); +} + +SKIP: +{ + $version >= 8 + or skip "Cannot retrieve before 5.8", 1; + my $x; + my $re = qr/a(?{ $x = 1 })/; + use re 'eval'; + ok(!eval { dclone($re) }, "should fail to clone, even with use re 'eval'"); +} + +for my $test (@tests) { + my ($code, $not, $match, $matchc, $name) = @$test; + my $qr = eval $code; + die "Could not compile $code: $@" if $@; + if ($not) { + unlike($match, $qr, "$name: pre(not) match $matchc"); + } + else { + like($match, $qr, "$name: prematch $matchc"); + } + my $qr2 = dclone($qr); + if ($not) { + unlike($match, $qr2, "$name: (not) match $matchc"); + } + else { + like($match, $qr2, "$name: match $matchc"); + } + + # this is unlikely to be a problem, but make sure regexps are frozen sanely + # as part of a data structure + my $a2 = dclone([ $qr ]); + if ($not) { + unlike($match, $a2->[0], "$name: (not) match $matchc (array)"); + } + else { + like($match, $a2->[0], "$name: match $matchc (array)"); + } +} + +__DATA__ +# semi-colon separated: +# perl version range; regexp qr; match string; name +# - version range is PERL_VERSION, ie 22 for 5.22 as from-to with both from +# and to optional (so "-" is all versions. +# - match string is , separated match strings +# - if a match string starts with ! it mustn't match, otherwise it must +# spaces around the commas ignored. +# The initial "!" is stripped and the remainder treated as perl code to define +# the string to (not) be matched +-; qr/foo/ ; "foo",!"fob" ; simple +-; qr/foo/i ; "foo","FOO",!"fob" ; simple case insensitive +-; qr/f o o/x ; "foo", !"f o o" ; /x +-; qr(a/b) ; "a/b" ; alt quotes +A-; qr(\x2E) ; ".", !"a" ; \x2E - hex meta +-; qr/\./ ; "." , !"a" ; \. - backslash meta +8- ; qr/\x{100}/ ; "\x{100}" ; simple unicode +12- ; qr/fss/i ; "f\xDF\x{101}" ; case insensive unicode promoted +22-; qr/fss/ui ; "f\xDF" ; case insensitive unicode SS /iu +22-; qr/fss/aai ; !"f\xDF" ; case insensitive unicode SS /iaa +22-; qr/f\w/a ; "fo", !"f\xff" ; simple /a flag diff --git a/t/restrict.t b/t/restrict.t new file mode 100644 index 0000000..41f7aad --- /dev/null +++ b/t/restrict.t @@ -0,0 +1,146 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 + # uninitialized 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'; + } +} + + +use Storable qw(dclone freeze thaw); +use Hash::Util qw(lock_hash unlock_value lock_keys); +use Config; +$Storable::DEBUGME = $ENV{STORABLE_DEBUGME}; +use Test::More tests => (!$Storable::DEBUGME && $Config{usecperl} ? 105 : 304); + +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; + is("@in_keys", "@out_keys", "keys match after deep clone"); + + # $copy = $hash; # used in initial debug of the tests + + is(Internals::SvREADONLY(%$copy), 1, "cloned hash restricted?"); + + is(Internals::SvREADONLY($copy->{question}), 1, + "key 'question' not locked in copy?"); + + is(Internals::SvREADONLY($copy->{answer}), '', + "key 'answer' not locked in copy?"); + + eval { $copy->{extra} = 15 } ; + is($@, '', "Can assign to reserved key 'extra'?"); + + eval { $copy->{nono} = 7 } ; + isnt($@, '', "Can not assign to invalid key 'nono'?"); + + is(exists $copy->{undef}, 1, "key 'undef' exists"); + + is($copy->{undef}, 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 } ; + is($@, '', "Can assign to reserved key '$k'?"); + } + + my %hv; + $hv{a} = __PACKAGE__; + lock_keys %hv; + my $hv2 = &$cloner(\%hv); + ok eval { $$hv2{a} = 70 }, 'COWs do not become read-only'; + } +} + +# [perl #73972] +# broken again with cperl PERL_PERTURB_KEYS_TOP. +SKIP: { + skip "TODO restricted Storable hashes broken with PERL_PERTURB_KEYS_TOP", 1 + if !$Storable::DEBUGME && $Config{usecperl}; + for my $n (1..100) { + my @keys = map { "FOO$_" } (1..$n); + + my $hash1 = {}; + lock_keys(%$hash1, @keys); + my $hash2 = dclone($hash1); + + my $success; + + $success = eval { $hash2->{$_} = 'test' for @keys; 1 }; + my $err = $@; + ok($success, "can store in all of the $n restricted slots") + || diag("failed with $@"); + + $success = !eval { $hash2->{a} = 'test'; 1 }; + ok($success, "the hash is still restricted"); + } +} diff --git a/t/retrieve.t b/t/retrieve.t new file mode 100644 index 0000000..ccd907b --- /dev/null +++ b/t/retrieve.t @@ -0,0 +1,86 @@ +#!./perl +# +# Copyright (c) 1995-2000, Raphael Manfredi +# Copyright (c) 2017, cPanel Inc +# +# 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, 'dist/Storable/t' if $ENV{PERL_CORE} and -d 'dist/Storable/t'; + unshift @INC, 't'; + unshift @INC, 't/compat' if $] < 5.006002; + 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); +use Test::More tests => 20; + +$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); + +isnt(store(\@a, "store$$"), undef); +is(Storable::last_op_in_netorder(), ''); +isnt(nstore(\@a, 'nstore'), undef); +is(Storable::last_op_in_netorder(), 1); +is(Storable::last_op_in_netorder(), 1); + +$root = retrieve("store$$"); +isnt($root, undef); +is(Storable::last_op_in_netorder(), ''); + +$nroot = retrieve('nstore'); +isnt($root, undef); +is(Storable::last_op_in_netorder(), 1); + +$d1 = &dump($root); +isnt($d1, undef); +$d2 = &dump($nroot); +isnt($d2, undef); + +is($d1, $d2); + +# Make sure empty string is defined at retrieval time +isnt($root->[1], undef); +is(length $root->[1], 0); + +# $Storable::DEBUGME = 1; +{ + # len>I32: todo patch the storable image number into the strings, fake 2.10 + # $Storable::BIN_MINOR + my $retrieve_blessed = "\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x11\xff\x49\x6e\x74\xff\x72\x6e\x61\x6c\x73\x02\x00\x00\x00\x00"; + my $x = eval { Storable::mretrieve($retrieve_blessed); }; + # Long integer or Double size or Byte order is not compatible + like($@, qr/^(Corrupted classname length|.* is not compatible|panic: malloc)/, "RT #130635 $@"); + is($x, undef, 'and undef result'); +} + +{ + # len>I32 + my $retrieve_hook = "\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x13\x04\x49\xfe\xf4\xff\x72\x6e\x61\x6c\x73\x02\x00\x00\x00\x00"; + my $x = eval { Storable::mretrieve($retrieve_hook); }; + like($@, qr/^(Corrupted classname length|.* is not compatible|panic: malloc)/, "$@"); + is($x, undef, 'and undef result'); +} + +{ + # len127: stack overflow + my $retrieve_hook = "\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x13\x04\x49\xfe\xf4\x7f\x72\x6e\x61\x6c\x73\x02\x00\x00\x00\x00"; + my $x = eval { Storable::mretrieve($retrieve_hook); }; + is($?, 0, "no stack overflow in retrieve_hook()"); + is($x, undef, 'either out of mem or normal error (malloc 2GB)'); +} + +END { 1 while unlink("store$$", 'nstore') } diff --git a/t/robust.t b/t/robust.t new file mode 100644 index 0000000..27f5fc0 --- /dev/null +++ b/t/robust.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl + +# This test script checks that Storable will load properly if someone +# is incorrectly messing with %INC to hide Log::Agent. No, no-one should +# really be doing this, but, then, it *used* to work! + +use Test::More; +plan tests => 1; + +$INC{'Log/Agent.pm'} = '#ignore#'; +require Storable; +pass; diff --git a/t/sig_die.t b/t/sig_die.t new file mode 100644 index 0000000..3ea2df4 --- /dev/null +++ b/t/sig_die.t @@ -0,0 +1,30 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 Test::More 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/t/st-dump.pl b/t/st-dump.pl new file mode 100644 index 0000000..50d8712 --- /dev/null +++ b/t/st-dump.pl @@ -0,0 +1,136 @@ +# +# 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. +# + +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 temporary 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/t/store.t b/t/store.t new file mode 100644 index 0000000..45af0b2 --- /dev/null +++ b/t/store.t @@ -0,0 +1,116 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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'; +} + +# $Storable::DEBUGME = 1; +use Storable qw(store retrieve store_fd nstore_fd fd_retrieve); + +use Test::More tests => 25; + +$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); + +isnt(store(\@a, "store$$"), undef); + +$dumped = &dump(\@a); +isnt($dumped, undef); + +$root = retrieve("store$$"); +isnt($root, undef); + +$got = &dump($root); +isnt($got, undef); + +is($got, $dumped); + +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; +isnt($foo->store("store$$"), undef); + +isnt(open(OUT, '>>', "store$$"), undef); +binmode OUT; + +isnt(store_fd(\@a, ::OUT), undef); +isnt(nstore_fd($foo, ::OUT), undef); +isnt(nstore_fd(\%a, ::OUT), undef); + +isnt(close(OUT), undef); + +isnt(open(OUT, "store$$"), undef); + +$r = fd_retrieve(::OUT); +isnt($r, undef); +is(&dump($r), &dump($foo)); + +$r = fd_retrieve(::OUT); +isnt($r, undef); +is(&dump($r), &dump(\@a)); + +$r = fd_retrieve(main::OUT); +isnt($r, undef); +is(&dump($r), &dump($foo)); + +$r = fd_retrieve(::OUT); +isnt($r, undef); +is(&dump($r), &dump(\%a)); + +eval { $r = fd_retrieve(::OUT); }; +isnt($@, ''); + +{ + my %test = ( + old_retrieve_array => "\x70\x73\x74\x30\x01\x0a\x02\x02\x02\x02\x00\x3d\x08\x84\x08\x85\x08\x06\x04\x00\x00\x01\x1b", + old_retrieve_hash => "\x70\x73\x74\x30\x01\x0a\x03\x00\xe8\x03\x00\x00\x81\x00\x00\x00\x01\x61", + retrieve_code => "\x70\x73\x74\x30\x05\x0a\x19\xf0\x00\xff\xe8\x03\x1a\x0a\x0e\x01", + ); + + for my $k (sort keys %test) { + open my $fh, '<', \$test{$k}; + eval { Storable::fd_retrieve($fh); }; + is($?, 0, 'RT 130098: no segfault in Storable::fd_retrieve()'); + } +} + +{ + + my $frozen = + "\x70\x73\x74\x30\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x03\xff\x00\x00\x00\x19\x08\xff\x00\x00\x00\x08\x08\xf9\x16\x16\x13\x16\x10\x10\x10\xff\x15\x16\x16\x16\x1e\x16\x16\x16\x16\x16\x16\x16\x16\x16\x16\x13\xf0\x16\x16\x16\xfe\x16\x41\x41\x41\x41\xe8\x03\x41\x41\x41\x41\x41\x41\x41\x41\x51\x41\xa9\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xb8\xac\xac\xac\xac\xac\xac\xac\xac\x9a\xac\xac\xac\xac\xac\xac\xac\xac\xac\x93\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\x00\x64\xac\xa8\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\x2c\xac\x41\x41\x41\x41\x41\x41\x41\x41\x41\x00\x80\x41\x80\x41\x41\x41\x41\x41\x41\x51\x41\xac\xac\xac"; + open my $fh, '<', \$frozen; + eval { Storable::fd_retrieve($fh); }; + pass('RT 130635: no stack smashing error when retrieving hook'); + +} + +close OUT or die "Could not close: $!"; +END { 1 while unlink "store$$" } diff --git a/t/testlib.pl b/t/testlib.pl new file mode 100644 index 0000000..a44c338 --- /dev/null +++ b/t/testlib.pl @@ -0,0 +1,38 @@ +#!perl -w +use strict; + +our $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 = ; + 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': $!"; + local *FH; + 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}; +} + +1; diff --git a/t/threads.t b/t/threads.t new file mode 100644 index 0000000..0b34334 --- /dev/null +++ b/t/threads.t @@ -0,0 +1,62 @@ + +# 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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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; + } + if ($] eq "5.008" || $] eq "5.010000") { + print "1..0 # Skip: threads unreliable in perl-$]\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'} =~ /(? 2; + +threads->new(\&sub1); + +$_->join() for threads->list(); + +ok 1; + +sub sub1 { + nfreeze {}; + ok 1; +} diff --git a/t/tied.t b/t/tied.t new file mode 100644 index 0000000..e8be39e --- /dev/null +++ b/t/tied.t @@ -0,0 +1,224 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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(freeze thaw); +$Storable::flags = Storable::FLAGS_COMPAT; + +use Test::More tests => 25; + +($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() incorrectly 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); + +my $f = freeze(\@a); +isnt($f, undef); + +$dumped = &dump(\@a); +isnt($dumped, undef); + +$root = thaw($f); +isnt($root, undef); + +$got = &dump($root); +isnt($got, undef); + +### Used to see the manifestation of the bug documented above. +### print "original: $dumped"; +### print "--------\n"; +### print "got: $got"; +### print "--------\n"; + +is($got, $dumped); + +$g = freeze($root); +is(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); + +is(ref tied $$tscalar, 'TIED_SCALAR'); +is(ref tied @$tarray, 'TIED_ARRAY'); +is(ref tied %$thash, 'TIED_HASH'); + +@new = ($$tscalar, $tarray->[0], $thash->{'attribute'}); +@new = ($scalar_fetch, $array_fetch, $hash_fetch); + +# Tests 10..15 +for ($i = 0; $i < @new; $i++) { + is($new[$i], $old[$i] + 1); + is(ref $tied[$i], $type[$i]); +} + +# Check undef ties +my $h = {}; +tie $h->{'x'}, 'FAULT', $h, 'x'; +my $hf = freeze($h); +isnt($hf, undef); +is($FAULT::fault, 0); +is($h->{'x'}, 1); +is($FAULT::fault, 1); + +my $ht = thaw($hf); +isnt($ht, undef); +is($ht->{'x'}, 1); +is($FAULT::fault, 2); + +{ + package P; + use Storable qw(freeze thaw); + our ($a, $b); + $b = "not ok "; + sub TIESCALAR { bless \$a } sub FETCH { "ok " } + tie $a, P; my $r = thaw freeze \$a; $b = $$r; + main::is($b, "ok "); +} + +{ + # blessed ref to tied object should be thawed blessed + my @a; + tie @a, TIED_ARRAY; + my $r = bless \@a, 'FOO99'; + my $f = freeze($r); + my $t = thaw($f); + isnt($t, undef); + like("$t", qr/^FOO99=ARRAY/); +} diff --git a/t/tied_hook.t b/t/tied_hook.t new file mode 100644 index 0000000..7f2bc98 --- /dev/null +++ b/t/tied_hook.t @@ -0,0 +1,246 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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(freeze thaw); + +$Storable::flags = Storable::FLAGS_COMPAT; + +use Test::More tests => 28; + +($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); + +my $f = freeze(\@a); +isnt($f, undef); +$dumped = &dump(\@a); +isnt($dumped, undef); + +$root = thaw($f); +isnt($root, undef); + +$got = &dump($root); +isnt($got, undef); + +isnt($got, $dumped); # our hooks did not handle refs in array + +$g = freeze($root); +is(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); + +is(ref tied $$tscalar, 'TIED_SCALAR'); +is(ref tied @$tarray, 'TIED_ARRAY'); +is(ref tied %$thash, 'TIED_HASH'); + +@new = ($$tscalar, $tarray->[0], $thash->{'attribute'}); +@new = ($scalar_fetch, $array_fetch, $hash_fetch); + +# Tests 10..15 +for ($i = 0; $i < @new; $i++) { + is($new[$i], $old[$i] + 1); # Tests 10,12,14 + is(ref $tied[$i], $type[$i]); # Tests 11,13,15 +} + +is($$tscalar, 'foo'); +is($tarray->[3], 'plaine scalaire'); +is($thash->{'attribute'}, 'plain value'); + +# Ensure hooks were called +is($scalar_hook1, 2); +is($scalar_hook2, 1); +is($array_hook1, 2); +is($array_hook2, 1); +is($hash_hook1, 2); +is($hash_hook2, 1); + +# +# 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; + +is(ref $bx, 'FOO'); +my $old_hash_fetch = $hash_fetch; +my $v = $bx->{attribute}; +is($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; + +is(ref $bx, 'TIED_HASH_REF'); +$old_hash_fetch = $hash_fetch; +$v = $bx->{attribute}; +is($hash_fetch, $old_hash_fetch + 1, 'Still tied'); diff --git a/t/tied_items.t b/t/tied_items.t new file mode 100644 index 0000000..3d13971 --- /dev/null +++ b/t/tied_items.t @@ -0,0 +1,59 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + require Config; import Config; + if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + exit 0; + } +} + +$^W = 0; + +use Storable qw(dclone); +use Test::More tests => 8; + +$Storable::flags = Storable::FLAGS_COMPAT; + +$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; + +is($h_fetches, 0); +is($$ref2, $$ref); +is($$ref2, 7); +is($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; + +is($a_fetches, 0); +is($$ref2, $$ref); +is($$ref2, 8); +# a bug in 5.12 and earlier caused an extra FETCH +is($a_fetches, $] < 5.013 ? 3 : 2); diff --git a/t/tied_reify.t b/t/tied_reify.t new file mode 100644 index 0000000..44e8637 --- /dev/null +++ b/t/tied_reify.t @@ -0,0 +1,36 @@ +use Test::More tests => 1; + +package dumb_thing; + +use strict; use warnings; +use Tie::Array; +use Carp; +use base 'Tie::StdArray'; + +sub TIEARRAY { + my $class = shift; + my $this = bless [], $class; + my $that = shift; + + @$this = @$that; + + $this; +} + +package main; + +use strict; use warnings; +use Storable qw(freeze thaw); + +my $x = [1,2,3,4]; + +broken($x); # ties $x +broken( thaw( freeze($x) ) ); # since 5.16 fails with "Cannot tie unreifiable array" + +sub broken { + my $w = shift; + tie @$_, dumb_thing => $_ for $w; +} + +# fails since 5.16 +ok 1, 'Does not fail with "Cannot tie unreifiable array" RT#84705'; diff --git a/t/tied_store.t b/t/tied_store.t new file mode 100644 index 0000000..c657f95 --- /dev/null +++ b/t/tied_store.t @@ -0,0 +1,64 @@ +#!./perl + +sub BEGIN { + unshift @INC, 't'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 => 3; + +our $f; + +package TIED_HASH; + +sub TIEHASH { bless({}, $_[0]) } + +sub STORE { + $f = Storable::freeze(\$_[2]); + 1; +} + +package TIED_ARRAY; + +sub TIEARRAY { bless({}, $_[0]) } + +sub STORE { + $f = Storable::freeze(\$_[2]); + 1; +} + +package TIED_SCALAR; + +sub TIESCALAR { bless({}, $_[0]) } + +sub STORE { + $f = Storable::freeze(\$_[1]); + 1; +} + +package main; + +my($s, @a, %h); +tie $s, "TIED_SCALAR"; +tie @a, "TIED_ARRAY"; +tie %h, "TIED_HASH"; + +$f = undef; +$s = 111; +is $f, Storable::freeze(\111); + +$f = undef; +$a[3] = 222; +is $f, Storable::freeze(\222); + +$f = undef; +$h{foo} = 333; +is $f, Storable::freeze(\333); + +1; diff --git a/t/utf8.t b/t/utf8.t new file mode 100644 index 0000000..a8dd6cd --- /dev/null +++ b/t/utf8.t @@ -0,0 +1,57 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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 Storable qw(thaw freeze); +use Test::More tests => 6; + +my $x = chr(1234); +is($x, ${thaw freeze \$x}); + +# Long scalar +$x = join '', map {chr $_} (0..1023); +is($x, ${thaw freeze \$x}); + +# Char in the range 127-255 (probably) in utf8. This just won't work for +# EBCDIC for early Perls. +$x = ($] lt 5.007_003) ? chr(175) : chr(utf8::unicode_to_native(175)) + . chr (256); +chop $x; +is($x, ${thaw freeze \$x}); + +# Storable needs to cope if a frozen string happens to be internal utf8 +# encoded + +$x = chr 256; +my $data = freeze \$x; +is($x, ${thaw $data}); + +$data .= chr 256; +chop $data; +is($x, ${thaw $data}); + + +$data .= chr 256; +# This definitely isn't valid +eval {thaw $data}; +like($@, qr/corrupt.*characters outside/); diff --git a/t/utf8hash.t b/t/utf8hash.t new file mode 100644 index 0000000..a2a8725 --- /dev/null +++ b/t/utf8hash.t @@ -0,0 +1,198 @@ +#!./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::flags = Storable::FLAGS_COMPAT; +$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/t/weak.t b/t/weak.t new file mode 100644 index 0000000..220c701 --- /dev/null +++ b/t/weak.t @@ -0,0 +1,145 @@ +#!./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'; + unshift @INC, 't/compat' if $] < 5.006002; + 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'; +our $file; +use strict; + +# $Storable::flags = Storable::FLAGS_COMPAT; + +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'); +}