1N/A * Store and retrieve mechanism. 1N/A * Copyright (c) 1995-2000, Raphael Manfredi 1N/A * You may redistribute only under the same terms as Perl 5, as specified 1N/A * in the README file that comes with the distribution. 1N/A#
define DEBUGME /* Debug mode, turns assertions on as well */ 1N/A#
if 0
/* On NetWare USE_PERLIO is not used */ 1N/A#
define DEBUGME /* Debug mode, turns assertions on as well */ 1N/A * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined 1N/A * Provide them with the necessary defines so they can build with pre-5.004. 1N/A#
endif /* PERLIO_IS_STDIO */ 1N/A#
endif /* USE_PERLIO */ 1N/A * Earlier versions of perl might be used, we can't assume they have the latest! 1N/A#
if (
PATCHLEVEL <=
4)
/* Older perls (<= 5.004) lack PL_ namespace */ 1N/A#
if (
SUBVERSION <=
4)
/* 5.004_04 has been reported to lack newSVpvn */ 1N/A#
endif /* PATCHLEVEL <= 4 */ 1N/A#
ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */ 1N/Atypedef double NV;
/* Older perls lack the NV type */ 1N/A#
define IVdf "ld" /* Various printf formats for Perl types */ 1N/A#
endif /* PERL_VERSION -- perls < 5.6 */ 1N/A#
ifndef NVef /* The following were not part of perl 5.6 */ 1N/A * TRACEME() will only output things when the $Storable::DEBUGME is true. 1N/A#
define C(x) ((
char) (x))
/* For markers with dynamic retrieval handling */ 1N/A#
define SX_LSCALAR C(
1)
/* Scalar (large binary) follows (length, data) */ 1N/A#
define SX_ARRAY C(
2)
/* Array forthcominng (size, item list) */ 1N/A#
define SX_REF C(
4)
/* Reference to object forthcoming */ 1N/A#
define SX_BYTE C(
8)
/* (signed) byte forthcoming */ 1N/A#
define SX_NETINT C(
9)
/* Integer in network order forthcoming */ 1N/A#
define SX_SCALAR C(
10)
/* Scalar (binary, small) follows (length, data) */ 1N/A#
define SX_IX_BLESS C(
18)
/* Object is blessed, classname given by index */ 1N/A#
define SX_HOOK C(
19)
/* Stored via hook, user-defined */ 1N/A#
define SX_CODE C(
26)
/* Code references as perl source code */ 1N/A * Those are only used to retrieve "old" pre-0.6 binary images. 1N/A#
define SX_KEY 'k' /* A hash key introducer */ 1N/A * Those are only used to retrieve "old" pre-0.7 binary images 1N/A#
define SX_CLASS 'b' /* Object is blessed, class name length <255 */ 1N/A#
define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */ 1N/A * The following structure is used for hash table key retrieval. Since, when 1N/A * retrieving objects, we'll be facing blessed hash references, it's best 1N/A * to pre-allocate that buffer once and resize it as the need arises, never 1N/A * freeing it (keys will be saved away someplace else anyway, so even large 1N/A * keys are not enough a motivation to reclaim that space). 1N/A * happen in a fixed place before being malloc'ed elsewhere if persistency 1N/A * is required. Hence the aptr pointer. 1N/A char *
arena;
/* Will hold hash key strings, resized as needed */ 1N/A char *
aend;
/* First invalid address */ 1N/A * A hash table records the objects which have already been stored. 1N/A * Those are referred to as SX_OBJECT in the file, and their "tag" (i.e. 1N/A * an arbitrary sequence number) is used to identify them. 1N/A * An array table records the objects which have already been retrieved, 1N/A * as seen by the tag determind by counting the objects themselves. The 1N/A * reference to that retrieved object is kept in the table, and is returned 1N/A * when an SX_OBJECT is found bearing that same tag. 1N/A * The same processing is used to record "classname" for blessed objects: 1N/A * indexing by a hash at store time, and via an array at retrieve time. 1N/Atypedef unsigned long stag_t;
/* Used by pre-0.6 binary format */ 1N/A * The following "thread-safe" related defines were contributed by 1N/A * Murray Nesbitt <murray@activestate.com> and integrated by RAM, who 1N/A * only renamed things a little bit to ensure consistency with surrounding 1N/A * code. -- RAM, 14/09/1999 1N/A * The original patch suffered from the fact that the stcxt_t structure 1N/A * was global. Murray tried to minimize the impact on the code as much as 1N/A * Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks 1N/A * on objects. Therefore, the notion of context needs to be generalized, 1N/A * Conditional UTF8 support. 1N/A/* 5.6 perl has utf8 scalars but not hashes */ 1N/A * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include 1N/A * files remap tainted and dirty when threading is enabled. That's bad for 1N/A * perl to remap such common words. -- RAM, 29/09/00 1N/A int optype;
/* type of traversal operation */ 1N/A HV *
hseen;
/* which objects have been seen, store time */ 1N/A AV *
aseen;
/* which objects have been seen, retrieve time */ 1N/A HV *
hclass;
/* which classnames have been seen, store time */ 1N/A AV *
aclass;
/* which classnames have been seen, retrieve time */ 1N/A HV *
hook;
/* cache for hook methods per class name */ 1N/A IV tagnum;
/* incremented at store time for each seen object */ 1N/A IV classnum;
/* incremented at store time for each seen classname */ 1N/A int s_tainted;
/* true if input source is tainted, at retrieve time */ 1N/A int s_dirty;
/* context is dirty due to CROAK() -- can be cleaned */ 1N/A int membuf_ro;
/* true means membuf is read-only and msaved is rw */ 1N/A SV *
prev;
/* contexts chained backwards in real recursion */ 1N/A SV *
my_sv;
/* the blessed scalar who's SvPVX() I am */ 1N/A#
else /* >= perl5.004_68 */ 1N/A#
endif /* < perl5.004_68 */ 1N/A#
else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */ 1N/A#
endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */ 1N/A * to catch the exit and free memory used during store or retrieve 1N/A * operations. This is not too difficult to fix, but I need to understand 1N/A * how Perl does it, and croaking is exceptional anyway, so I lack the 1N/A * motivation to do it. 1N/A * The current workaround is to mark the context as dirty when croaking, 1N/A * so that data structures can be freed whenever we renter Storable code 1N/A * (but only *then*: it's a workaround, not a fix). 1N/A * This is also imperfect, because we don't really know how far they trapped 1N/A * the croak(), and when we were recursing, we won't be able to clean anything 1N/A * but the topmost context stacked. 1N/A * End of "thread-safe" related definitions. 1N/A * Keep only the low 32 bits of a pointer (used for tags, which are not 1N/A * Hack for Crays, where sizeof(I32) == 8, and which are big-endians. 1N/A * Used in the WLEN and RLEN macros. 1N/A#
define oI(x) ((
I32 *) ((
char *) (x) +
4))
1N/A * key buffer handling 1N/A * memory buffer handling 1N/A ((
unsigned long) ((
unsigned long) (x) & ~(
sizeof(
int)-
1)))
1N/A * MBUF_SAVE_AND_LOAD 1N/A * Those macros are used in do_retrieve() to save the current memory 1N/A * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve 1N/A * data from a string. 1N/A * Use SvPOKp(), because SvPOK() fails on tainted scalars. 1N/A * See store_scalar() for other usage of this workaround. 1N/A TRACEME((
"** extending mbase from %d to %d bytes (wants %d new)", \
1N/A x = (
int) (
unsigned char) *
mptr++; \
1N/A * Possible return values for sv_type(). 1N/A * Flags for SX_HOOK. 1N/A * Types for SX_HOOK (last 2 bits in flags). 1N/A * The following are held in the "extra byte"... 1N/A * per hash flags for flagged hashes 1N/A * per key flags for flagged hashes 1N/A * Before 0.6, the magic string was "perl-store" (binary version number 0). 1N/A * Since 0.6 introduced many binary incompatibilities, the magic string has 1N/A * been changed to "pst0" to allow an old image to be properly retrieved by 1N/A * a newer Storable, but ensure a newer image cannot be retrieved with an 1N/A * At 0.7, objects are given the ability to serialize themselves, and the 1N/A * set of markers is extended, backward compatibility is not jeopardized, 1N/A * so the binary version number could have remained unchanged. To correctly 1N/A * spot errors if a file making use of 0.7-specific extensions is given to 1N/A * 0.6 for retrieval, the binary version was moved to "2". And I'm introducing 1N/A * a "minor" version, to better track this kind of evolution from now on. 1N/Astatic const char old_magicstr[] =
"perl-store";
/* Magic number before 0.6 */ 1N/Astatic const char magicstr[] =
"pst0";
/* Used as a magic number */ 1N/A/* 5.6.x introduced the ability to have IVs as long long. 1N/A However, Configure still defined BYTEORDER based on the size of a long. 1N/A Storable uses the BYTEORDER value as part of the header, but doesn't 1N/A explicity store sizeof(IV) anywhere in the header. Hence on 5.6.x built 1N/A with IV as long long on a platform that uses Configure (ie most things 1N/A except VMS and Windows) headers are identical for the different IV sizes, 1N/A despite the files containing some fields based on sizeof(IV) 1N/A 5.8 is consistent - the following redifinition kludge is only needed on 1N/A 5.6.x, but the interwork is needed on 5.8 while data survives in files 1N/A with the 5.6 header. 1N/A/* If we aren't 5.7.3 or later, we won't be writing out files that use the 1N/A * new flagged hash introdued in 2.5, so put 2.4 in the binary header to 1N/A * maximise ease of interoperation with older Storables. 1N/A * Could we write 2.3s if we're on 5.005_03? NWC 1N/A * As of perl 5.7.3, utf8 hash key is introduced. 1N/A * So this must change -- dankogai 1N/A#
endif /* (PATCHLEVEL <= 6) */ 1N/A * Useful store shortcuts... 1N/A * Note that if you put more than one mark for storing a particular 1N/A * type of thing, *and* in the retrieve_foo() function you mark both 1N/A * the thingy's you get off with SEEN(), you *must* increase the 1N/A * tagnum with cxt->tagnum++ along with this macro! 1N/A * Store &PL_sv_undef in arrays without recursing through store(). 1N/A * Useful retrieve shortcuts... 1N/A * This macro is used at retrieve time, to remember where object 'y', bearing a 1N/A * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker, 1N/A * we'll therefore know where it has been retrieved and will be able to 1N/A * share the same reference, as in the original stored memory image. 1N/A * We also need to bless objects ASAP for hooks (which may compute "ref $x" 1N/A * on the objects given to STORABLE_thaw and expect that to be defined), and 1N/A * also for overloaded objects (for which we might not find the stash if the 1N/A * object is not blessed yet--this might occur for overloaded objects that 1N/A * refer to themselves indirectly: if we blessed upon return from a sub 1N/A * retrieve(), the SX_OBJECT marker we'd found could not have overloading 1N/A * restored on it because the underlying object would not be blessed yet!). 1N/A * To achieve that, the class name of the last retrieved object is passed down 1N/A * recursively, and the first SEEN() call for which the class name is not NULL 1N/A * will bless the object. 1N/A * i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef) 1N/A * Bless `s' in `p', via a temporary reference, required by sv_bless(). 1N/A * sort (used in store_hash) - conditionally use qsort when 1N/A * sortsv is not available ( <= 5.6.1 ). 1N/A#
else /* ! USE_ITHREADS */ 1N/A#
endif /* USE_ITHREADS */ 1N/A#
else /* PATCHLEVEL > 6 */ 1N/A#
endif /* PATCHLEVEL <= 6 */ 1N/A * Dynamic dispatching table for SV store. 1N/A * Dynamic dispatching tables for SV retrieval. 1N/A 0,
/* SX_OBJECT -- entry unused dynamically */ 1N/A 0,
/* SX_OBJECT -- entry unused dynamically */ 1N/A *** Context management. 1N/A * Called once per "thread" (interpreter) to initialize some global context. 1N/A * Called at the end of every context cleaning, to perform common reset 1N/A * init_store_context 1N/A * Initialize a new store context for real recursion. 1N/A * The `hseen' table is used to keep track of each SV stored and their 1N/A * associated tag numbers is special. It is "abused" because the 1N/A * values stored are not real SV, just integers cast to (SV *), 1N/A * which explains the freeing below. 1N/A * It is also one possible bottlneck to achieve good storing speed, 1N/A * so the "shared keys" optimization is turned off (unlikely to be 1N/A * of any use here), and the hash table is "pre-extended". Together, 1N/A * those optimizations increase the throughput by 12%. 1N/A * The following does not work well with perl5.004_04, and causes 1N/A * a core dump later on, in a completely unrelated spot, which 1N/A * makes me think there is a memory corruption going on. 1N/A * Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking 1N/A * it below does not make any difference. It seems to work fine 1N/A * with perl5.004_68 but given the probable nature of the bug, 1N/A * that does not prove anything. 1N/A * It's a shame because increasing the amount of buckets raises 1N/A * store() throughput by 5%, but until I figure this out, I can't 1N/A * allow for this to go into production. 1N/A * It is reported fixed in 5.005, hence the #if. 1N/A * The `hclass' hash uses the same settings as `hseen' above, but it is 1N/A * used to assign sequential tags (numbers) to class names for blessed 1N/A * We turn the shared key optimization on. 1N/A * The `hook' hash table is used to keep track of the references on 1N/A * the STORABLE_freeze hook routines, when found in some class name. 1N/A * It is assumed that the inheritance tree will not be changed during 1N/A * storing, and that no new method will be dynamically created by the 1N/A * The `hook_seen' array keeps track of all the SVs returned by 1N/A * STORABLE_freeze hooks for us to serialize, so that they are not 1N/A * reclaimed until the end of the serialization process. Each SV is 1N/A * only stored once, the first time it is seen. 1N/A * clean_store_context 1N/A * Clean store context by 1N/A * Insert real values into hashes where we stored faked pointers. 1N/A * And now dispose of them... 1N/A * The surrounding if() protection has been added because there might be 1N/A * some cases where this routine is called more than once, during 1N/A * exceptionnal events. This was reported by Marc Lehmann when Storable 1N/A * is executed from mod_perl, and the fix was suggested by him. 1N/A * -- RAM, 20/12/2000 1N/A * init_retrieve_context 1N/A * Initialize a new retrieve context for real recursion. 1N/A * The hook hash table is used to keep track of the references on 1N/A * the STORABLE_thaw hook routines, when found in some class name. 1N/A * It is assumed that the inheritance tree will not be changed during 1N/A * storing, and that no new method will be dynamically created by the 1N/A * If retrieving an old binary version, the cxt->retrieve_vtbl variable 1N/A * was set to sv_old_retrieve. We'll need a hash table to keep track of 1N/A * the correspondance between the tags and the tag number used by the 1N/A * new retrieve routines. 1N/A * clean_retrieve_context 1N/A * Clean retrieve context by 1N/A * A workaround for the CROAK bug: cleanup the last context. 1N/A * Allocate a new context and push it on top of the parent one. 1N/A * This new context is made globally visible via SET_STCXT(). 1N/A * Free current context, which cannot be the "root" one. 1N/A * Make the context underneath globally visible via SET_STCXT(). 1N/A * Tells whether we're in the middle of a store operation. 1N/A * Tells whether we're in the middle of a retrieve operation. 1N/A * last_op_in_netorder 1N/A * Returns whether last operation was made using network order. 1N/A * This is typically out-of-band information that might prove useful 1N/A * to people wishing to convert native to network order data when used. 1N/A *** Hook lookup and calling routines. 1N/A * A wrapper on gv_fetchmethod_autoload() which caches results. 1N/A * Returns the routine reference as an SV*, or null if neither the package 1N/A * nor its ancestors know about the method. 1N/A * The following code is the same as the one performed by UNIVERSAL::can 1N/A * Cache the result, ignoring failure: if we can't store the value, 1N/A * it just won't be cached. 1N/A * Force cached value to be undef: hook ignored even if present. 1N/A * Discard cached value: a whole fetch loop will be retried at next lookup. 1N/A * Our own "UNIVERSAL::can", which caches results. 1N/A * Returns the routine reference as an SV*, or null if the object does not 1N/A * know about the method. 1N/A * Look into the cache to see whether we already have determined 1N/A * where the routine was, if any. 1N/A * NOTA BENE: we don't use `method' at all in our lookup, since we know 1N/A * that only one hook (i.e. always the same) is cached in a given cache. 1N/A * Call routine as obj->hook(av) in scalar context. 1N/A * Propagates the single returned value if not called in void context. 1N/A * Call routine obj->hook(cloning) in list context. 1N/A * Returns the list of returned values in an array. 1N/A * Lookup the class name in the `hclass' table and either assign it a new ID 1N/A * or return the existing one, by filling in `classnum'. 1N/A * Return true if the class was known, false if the ID was just generated. 1N/A * Recall that we don't store pointers in this hash table, but tags. 1N/A * Therefore, we need LOW_32BITS() to extract the relevant parts. 1N/A * Unknown classname, we need to record it. 1N/A CROAK((
"Unable to record new classname"));
1N/A *** Sepcific store routines. 1N/A * Store a reference. 1N/A * Layout is SX_REF <object> or SX_OVERLOAD <object>. 1N/A * Follow reference, and check if target is overloaded. 1N/A * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF. 1N/A * The <data> section is omitted if <length> is 0. 1N/A * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>. 1N/A * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>. 1N/A * For efficiency, break the SV encapsulation by peaking at the flags 1N/A * directly without using the Perl macros to avoid dereferencing 1N/A * sv->sv_flags each time we wish to check the flags. 1N/A * Always store the string representation of a scalar if it exists. 1N/A * Gisle Aas provided me with this test case, better than a long speach: 1N/A * perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)' 1N/A * SV = PVNV(0x80c8520) 1N/A * FLAGS = (NOK,POK,pNOK,pPOK) 1N/A * PV = 0x80c83d0 "abc"\0 1N/A * Write SX_SCALAR, length, followed by the actual data. 1N/A * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as 1N/A * appropriate, followed by the actual (binary) data. A double 1N/A * is written as a string if network order, for portability. 1N/A * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv). 1N/A * The reason is that when the scalar value is tainted, the SvNOK(sv) 1N/A * The test for a read-only scalar with both POK and NOK set is meant 1N/A * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the 1N/A * address comparison for each scalar we store. 1N/A /* public string - go direct to string read. */ 1N/A /* For 5.6 and earlier NV flag trumps IV flag, so only use integer 1N/A direct if NV flag is off. */ 1N/A /* 5.7 rules are that if IV public flag is set, IV value is as 1N/A good, if not better, than NV value. */ 1N/A * Will come here from below with iv set if double is an integer. 1N/A /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ 1N/A /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1 1N/A * (for example) and that ends up in the optimised small integer 1N/A * Optimize small integers into a single byte, otherwise store as 1N/A * a real integer (converted into network order if they asked). 1N/A unsigned char siv = (
unsigned char) (
iv +
128);
/* [0,255] */ 1N/A TRACEME((
"no htonl, fall back to string for integer"));
1N/A /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ 1N/A (
iv >
0x7FFFFFFF) || (
iv < -
0x80000000)) {
1N/A /* Bigger than 32 bits. */ 1N/A * Watch for number being an integer in disguise. 1N/A * Will come here from above if it was readonly, POK and NOK but 1N/A * neither &PL_sv_yes nor &PL_sv_no. 1N/A return 0;
/* Ok, no recursion on scalars */ 1N/A * Layout is SX_ARRAY <size> followed by each item, in increading index order. 1N/A * Each item is stored as <object>. 1N/A * Signal array by emitting SX_ARRAY, followed by the array length. 1N/A * Now store each item recursively. 1N/A * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort. 1N/A#
endif /* USE_ITHREADS */ 1N/A#
endif /* PATCHLEVEL <= 6 */ 1N/A * Store a hash table. 1N/A * For a "normal" hash (not restricted, no utf8 keys): 1N/A * Layout is SX_HASH <size> followed by each key/value pair, in random order. 1N/A * Values are stored as <object>. 1N/A * Keys are stored as <length> <data>, the <data> section being omitted 1N/A * For a "fancy" hash (restricted or utf8 keys): 1N/A * Layout is SX_FLAG_HASH <size> <hash flags> followed by each key/value pair, 1N/A * Values are stored as <object>. 1N/A * Keys are stored as <flags> <length> <data>, the <data> section being omitted 1N/A * Currently the only hash flag is "restriced" 1N/A /* needs int cast for C++ compilers, doesn't it? */ 1N/A * Signal hash by emitting SX_HASH, followed by the table length. 1N/A * Save possible iteration state via each() on that table. 1N/A * Now store each item recursively. 1N/A * If canonical is defined to some true value then store each 1N/A * key/value pair in sorted order otherwise the order is random. 1N/A * Canonical order is irrelevant when a deep clone operation is performed. 1N/A * Fetch the value from perl only once per store() operation, and only 1N/A * Storing in order, sorted by key. 1N/A * Run through the hash, building up an array of keys in a 1N/A * mortal array, sort the array and then run through the 1N/A /*av_extend (av, len);*/ 1N/A /* This will fail if key is a placeholder. 1N/A Track how many placeholders we have, and error if we 1N/A /* Internal error, not I/O error */ 1N/A /* Should be a placeholder. */ 1N/A /* This should not happen - number of 1N/A retrieves should be identical to 1N/A number of placeholders. */ 1N/A /* Value is never needed, and PL_sv_undef is 1N/A more space efficient to store. */ 1N/A * Store value first. 1N/A * Keys are written after values to make sure retrieval 1N/A * can be optimal in terms of memory usage, where keys are 1N/A * read into a fixed unique buffer called kbuf. 1N/A * See retrieve_hash() for details. 1N/A /* Implementation of restricted hashes isn't nicely 1N/A /* If you build without optimisation on pre 5.6 1N/A then nothing spots that SvUTF8(key) is always 0, 1N/A so the block isn't optimised away, at which point 1N/A the linker dislikes the reference to 1N/A /* Just casting the &klen to (STRLEN) won't work 1N/A well if STRLEN and I32 are of different widths. 1N/A /* If we were able to downgrade here, then than 1N/A means that we have a key which only had chars 1N/A 0-255, but was utf8 encoded. */ 1N/A /* keylen_tmp can't have changed, so no need 1N/A to assign back to keylen. */ 1N/A /* This is a workaround for a bug in 5.8.0 1N/A that causes the HEK_WASUTF8 flag to be 1N/A set on an HEK without the hash being 1N/A marked as having key flags. We just 1N/A cross our fingers and drop the flag. 1N/A * Free up the temporary array 1N/A * Storing in "random" order (in the order the keys are stored 1N/A * within the hash). This is the default and will be faster! 1N/A return 1;
/* Internal error, not I/O error */ 1N/A /* Implementation of restricted hashes isn't nicely 1N/A * Store value first. 1N/A /* This is somewhat sick, but the internal APIs are 1N/A * such that XS code could put one of these in in 1N/A * Maybe we should be capable of storing one if 1N/A /* Regular string key. */ 1N/A * Keys are written after values to make sure retrieval 1N/A * can be optimal in terms of memory usage, where keys are 1N/A * read into a fixed unique buffer called kbuf. 1N/A * See retrieve_hash() for details. 1N/A /* This is a workaround for a bug in 5.8.0 1N/A that causes the HEK_WASUTF8 flag to be 1N/A set on an HEK without the hash being 1N/A marked as having key flags. We just 1N/A cross our fingers and drop the flag. 1N/A * Store a code reference. 1N/A * Layout is SX_CODE <length> followed by a scalar containing the perl 1N/A * source code of the code reference. 1N/A * retrieve_code does not work with perl 5.005 or less 1N/A * Require B::Deparse. At least B::Deparse 0.61 is needed for 1N/A * blessed code references. 1N/A /* Ownership of both SVs is passed to load_module, which frees them. */ 1N/A * create the B::Deparse object 1N/A CROAK((
"Unexpected return value from B::Deparse::new\n"));
1N/A * call the coderef2text method 1N/A CROAK((
"Unexpected return value from B::Deparse::coderef2text\n"));
1N/A * Empty code references or XS functions are deparsed as 1N/A * "(prototype) ;" or ";". 1N/A CROAK((
"The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"));
1N/A * Signal code by emitting SX_CODE. 1N/A cxt->
tagnum++;
/* necessary, as SX_CODE is a SEEN() candidate */ 1N/A * Now store the source code. 1N/A * When storing a tied object (be it a tied scalar, array or hash), we lay out 1N/A * a special mark, followed by the underlying tied object. For instance, when 1N/A * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where 1N/A * <hash object> stands for the serialization of the tied hash. 1N/A * We have a small run-time penalty here because we chose to factorise 1N/A * all tieds objects into the same routine, and not have a store_tied_hash, 1N/A * a store_tied_array, etc... 1N/A * Don't use a switch() statement, as most compilers don't optimize that 1N/A * well for 2/3 values. An if() else if() cascade is just fine. We put 1N/A * tied hashes first, as they are the most likely beasts. 1N/A * The mg->mg_obj found by mg_find() above actually points to the 1N/A * underlying tied Perl object implementation. For instance, if the 1N/A * original SV was that of a tied array, then mg->mg_obj is an AV. 1N/A * Note that we store the Perl object as-is. We don't call its FETCH 1N/A * method along the way. At retrieval time, we won't call its STORE 1N/A * method either, but the tieing magic will be re-installed. In itself, 1N/A * that ensures that the tieing semantics are preserved since futher 1N/A * accesses on the retrieved object will indeed call the magic methods... 1N/A /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */ 1N/A * Stores a reference to an item within a tied structure: 1N/A * . \$h{key}, stores both the (tied %h) object and 'key'. 1N/A * . \$a[idx], stores both the (tied @a) object and 'idx'. 1N/A * Layout is therefore either: 1N/A * SX_TIED_KEY <object> <key> 1N/A * SX_TIED_IDX <object> <index> 1N/A CROAK((
"No magic 'p' found while storing reference to tied item"));
1N/A * We discriminate between \$h{key} and \$a[idx] via mg_ptr. 1N/A TRACEME((
"store_tied_item: storing a ref to a tied hash item"));
1N/A TRACEME((
"store_tied_item: storing a ref to a tied array item "));
1N/A * store_hook -- dispatched manually, not via sv_store[] 1N/A * The blessed SV is serialized by a hook. 1N/A * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>] 1N/A * where <flags> indicates how long <len>, <len2> and <len3> are, whether 1N/A * the trailing part [] is present, the type of object (scalar, array or hash). 1N/A * There is also a bit which says how the classname is stored between: 1N/A * and when the <index> form is used (classname already seen), the "large 1N/A * classname" bit in <flags> indicates how large the <index> is. 1N/A * The serialized string returned by the hook is of length <len2> and comes 1N/A * next. It is an opaque string for us. 1N/A * Those <len3> object IDs which are listed last represent the extra references 1N/A * not directly serialized by the hook, but which are linked to the object. 1N/A * When recursion is mandated to resolve object-IDs not yet seen, we have 1N/A * instead, with <header> being flags with bits set to indicate the object type 1N/A * and that recursion was indeed needed: 1N/A * SX_HOOK <header> <object> <header> <object> <flags> 1N/A * that same header being repeated between serialized objects obtained through 1N/A * recursion, until we reach flags indicating no recursion, at which point 1N/A * we know we've resynchronized with a single layout, after <flags>. 1N/A * When storing a blessed ref to a tied variable, the following format is 1N/A * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object> 1N/A * The first <flags> indication carries an object of type SHT_EXTRA, and the 1N/A * real object type is held in the <extra> flag. At the very end of the 1N/A * serialization stream, the underlying magic object is serialized, just like 1N/A * any other tied variable. 1N/A char mtype =
'\0';
/* for blessed ref to tied structures */ 1N/A unsigned char eflags =
'\0';
/* used when object type is SHT_EXTRA */ 1N/A * Determine object type on 2 bits. 1N/A * Produced by a blessed ref to a tied data structure, $o in the 1N/A * following Perl code. 1N/A * my $o = bless \%h, 'BAR'; 1N/A * Signal the tie-ing magic by setting the object type as SHT_EXTRA 1N/A * (since we have only 2 bits in <flags> to store the type), and an 1N/A * <extra> byte flag will be emitted after the FIRST <flags> in the 1N/A * stream, carrying what we put in `eflags'. 1N/A CROAK((
"Unexpected object type (%d) in store_hook()",
type));
1N/A * To call the hook, we need to fake a call like: 1N/A * $object->STORABLE_freeze($cloning); 1N/A * but we don't have the $object here. For instance, if $object is 1N/A * a blessed array, what we have in `sv' is the array, and we can't 1N/A * call a method on those. 1N/A * Therefore, we need to create a temporary reference to the object and 1N/A * make the call on that reference. 1N/A * If they return an empty list, it means they wish to ignore the 1N/A * hook for this class (and not just this instance -- that's for them 1N/A * to handle if they so wish). 1N/A * Simply disable the cached entry for the hook (it won't be recomputed 1N/A * since it's present in the cache) and recurse to store_blessed(). 1N/A * They must not change their mind in the middle of a serialization. 1N/A CROAK((
"Too late to ignore hooks for %s class \"%s\"",
1N/A * Get frozen string. 1N/A * If they returned more than one item, we need to serialize some 1N/A * extra references if not already done. 1N/A * Loop over the array, starting at position #1, and for each item, 1N/A * ensure it is a reference, serialize it if not already done, and 1N/A * replace the entry with the tag ID of the corresponding serialized 1N/A * We CHEAT by not calling av_fetch() and read directly within the 1N/A CROAK((
"Item #%d returned by STORABLE_freeze " 1N/A "for %s is not a reference", i,
class));
1N/A * Look in hseen and see if we have a tag already. 1N/A * Serialize entry if not done already, and get its tag. 1N/A goto sv_seen;
/* Avoid moving code too far to the right */ 1N/A * We need to recurse to store that object and get it to be known 1N/A * so that we can resolve the list of object-IDs at retrieve time. 1N/A * The first time we do this, we need to emit the proper header 1N/A * indicating that we recursed, and what the type of object is (the 1N/A * object we're storing via a user-hook). Indeed, during retrieval, 1N/A * we'll have to create the object before recursing to retrieve the 1N/A * others, in case those would point back at that object. 1N/A /* [SX_HOOK] <flags> [<extra>] <object>*/ 1N/A CROAK((
"Could not serialize item #%d from hook in %s", i,
class));
1N/A * It was the first time we serialized `xsv'. 1N/A * Keep this SV alive until the end of the serialization: if we 1N/A * disposed of it right now by decrementing its refcount, and it was 1N/A * a temporary value, some next temporary value allocated during 1N/A * another STORABLE_freeze might take its place, and we'd wrongly 1N/A * assume that new SV was already serialized, based on its presence 1N/A * Therefore, push it away in cxt->hook_seen. 1N/A * Dispose of the REF they returned. If we saved the `xsv' away 1N/A * in the array of returned SVs, that will not cause the underlying 1N/A * referenced SV to be reclaimed. 1N/A * Replace entry with its tag (not a real SV, so no refcnt increment) 1N/A * Allocate a class ID if not already done. 1N/A * This needs to be done after the recursion above, since at retrieval 1N/A * time, we'll see the inner objects first. Many thanks to 1N/A * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and 1N/A * proposed the right fix. -- RAM, 15/09/2000 1N/A * Compute leading flags. 1N/A * We're ready to emit either serialized form: 1N/A * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>] 1N/A * SX_HOOK <flags> <index> <len2> <str> [<len3> <object-IDs>] 1N/A * If we recursed, the SX_HOOK has already been emitted. 1N/A /* SX_HOOK <flags> [<extra>] */ 1N/A /* <len> <classname> or <index> */ 1N/A /* <len2> <frozen-str> */ 1N/A /* [<len3> <object-IDs>] */ 1N/A * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a 1N/A * real pointer, rather a tag number, well under the 32-bit limit. 1N/A * Free the array. We need extra care for indices after 0, since they 1N/A * don't hold real SVs but integers cast. 1N/A * If object was tied, need to insert serialization of the magic object. 1N/A CROAK((
"No magic '%c' found while storing ref to tied %s with hook",
1N/A * store_blessed -- dispatched manually, not via sv_store[] 1N/A * Check whether there is a STORABLE_xxx hook defined in the class or in one 1N/A * of its ancestors. If there is, then redispatch to store_hook(); 1N/A * Otherwise, the blessed SV is stored using the following layout: 1N/A * SX_BLESS <flag> <len> <classname> <object> 1N/A * where <flag> indicates whether <len> is stored on 0 or 4 bytes, depending 1N/A * on the high-order bit in flag: if 1, then length follows on 4 bytes. 1N/A * Otherwise, the low order bits give the length, thereby giving a compact 1N/A * representation for class names less than 127 chars long. 1N/A * Each <classname> seen is remembered and indexed, so that the next time 1N/A * an object in the blessed in the same <classname> is stored, the following 1N/A * SX_IX_BLESS <flag> <index> <object> 1N/A * where <index> is the classname index, stored on 0 or 4 bytes depending 1N/A * on the high-order bit in flag (same encoding as above for <len>). 1N/A * Look for a hook for this blessed SV and redirect to store_hook() 1N/A * This is a blessed SV without any serialization hook. 1N/A * Determine whether it is the first time we see that class name (in which 1N/A * case it will be stored in the SX_BLESS form), or whether we already 1N/A * saw that class name before (in which case the SX_IX_BLESS form will be 1N/A unsigned char flag = (
unsigned char)
0x80;
1N/A unsigned char flag = (
unsigned char)
0x80;
1N/A WLEN(
len);
/* Don't BER-encode, this should be rare */ 1N/A * Now emit the <object> part. 1N/A * We don't know how to store the item we reached, so return an error condition. 1N/A * (it's probably a GLOB, some CODE reference, etc...) 1N/A * If they defined the `forgive_me' variable at the Perl level to some 1N/A * true value, then don't croak, just warn, and store a placeholder string 1N/A * Fetch the value from perl only once per store() operation. 1N/A * Store placeholder string as a scalar instead... 1N/A *** Store driving routines 1N/A * WARNING: partially duplicates Perl's sv_reftype for speed. 1N/A * Returns the type of the SV, identified by an integer. That integer 1N/A * may then be used to index the dynamic routine dispatch table. 1N/A * No need to check for ROK, that can't be set here since there 1N/A * is no field capable of hodling the xrv_rv reference. 1N/A * Starting from SVt_PV, it is possible to have the ROK flag 1N/A * set, the pointer to the other SV being either stored in 1N/A * the xrv_rv (in the case of a pure SVt_RV), or as the 1N/A * xpv_pv field of an SVt_PV and its heirs. 1N/A * However, those SV cannot be magical or they would be an 1N/A * SVt_PVMG at least. 1N/A case SVt_PVLV:
/* Workaround for perl5.004_04 "LVALUE" bug */ 1N/A * Recursively store objects pointed to by the sv to the specified file. 1N/A * Layout is <content> or SX_OBJECT <tagnum> if we reach an already stored 1N/A * object (one for which storage has started -- it may not be over if we have 1N/A * a self-referenced structure). This data set forms a stored <object>. 1N/A * If object has already been stored, do not duplicate data. 1N/A * Simply emit the SX_OBJECT marker followed by its tag data. 1N/A * The tag is always written in network order. 1N/A * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a 1N/A * real pointer, rather a tag number (watch the insertion code below). 1N/A * That means it probably safe to assume it is well under the 32-bit limit, 1N/A * and makes the truncation safe. 1N/A * -- RAM, 14/09/1999 1N/A /* We have seen PL_sv_undef before, but fake it as 1N/A Not the simplest solution to making restricted 1N/A hashes work on 5.8.0, but it does mean that 1N/A repeated references to the one true undef will 1N/A take up less space in the output file. 1N/A /* Need to jump past the next hv_store, because on the 1N/A second store of undef the old hash value will be 1N/A SvREFCNT_dec()ed, and as Storable cheats horribly 1N/A by storing non-SVs in the hash a SEGV will ensure. 1N/A Need to increase the tag number so that the 1N/A receiver has no idea what games we're up to. This 1N/A special casing doesn't affect hooks that store 1N/A undef, as the hook routine does its own lookup into 1N/A hseen. Also this means that any references back 1N/A to PL_sv_undef (from the pathological case of hooks 1N/A storing references to it) will find the seen hash 1N/A entry for the first time, as if we didn't have this 1N/A hackery here. (That hseen lookup works even on 5.8.0 1N/A because it's a key of &PL_sv_undef and a value 1N/A which is a tag number, not a value which is 1N/A * Allocate a new tag and associate it with the address of the sv being 1N/A * stored, before recursing... 1N/A * In order to avoid creating new SvIVs to hold the tagnum we just 1N/A * cast the tagnum to an SV pointer and store that in the hash. This 1N/A * means that we must clean up the hash manually afterwards, but gives 1N/A * us a 15% throughput increase. 1N/A * Store `sv' and everything beneath it, using appropriate routine. 1N/A * Abort immediately if we get a non-zero status back. 1N/A * Write magic number and system information into the file. 1N/A * Layout is <magic> <network> [<len> <byteorder> <sizeof int> <sizeof long> 1N/A * <sizeof ptr>] where <len> is the length of the byteorder hexa string. 1N/A * All size and lenghts are written as single characters here. 1N/A * Note that no byte ordering info is emitted when <network> is true, since 1N/A * integers will be emitted in network order in that case. 1N/A * Starting with 0.6, the "use_network_order" byte flag is also used to 1N/A * indicate the version number of the binary image, encoded in the upper 1N/A * bits. The bit 0 is always used to indicate network order. 1N/A * Starting with 0.7, a full byte is dedicated to the minor version of 1N/A * the binary format, which is incremented only when new markers are 1N/A * introduced, for instance, but when backward compatibility is preserved. 1N/A /* Make these at compile time. The WRITE() macro is sufficiently complex 1N/A that it saves about 200 bytes doing it this way and only using it 1N/A /* sizeof the array includes the 0 byte at the end: */ 1N/A (
unsigned char)
sizeof(
int),
1N/A (
unsigned char)
sizeof(
long),
1N/A (
unsigned char)
sizeof(
char *),
1N/A (
unsigned char)
sizeof(
NV)
1N/A /* sizeof the array includes the 0 byte at the end: */ 1N/A (
unsigned char)
sizeof(
int),
1N/A (
unsigned char)
sizeof(
long),
1N/A (
unsigned char)
sizeof(
char *),
1N/A (
unsigned char)
sizeof(
NV)
1N/A /* sizeof the array includes the 0 byte at the end. */ 1N/A TRACEME((
"ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
1N/A (
int)
sizeof(
int), (
int)
sizeof(
long),
1N/A (
int)
sizeof(
char *), (
int)
sizeof(
NV)));
1N/A * Common code for store operations. 1N/A * When memory store is requested (f = NULL) and a non null SV* is given in 1N/A * `res', it is filled with a new SV created out of the memory buffer. 1N/A * It is required to provide a non-null `res' when the operation type is not 1N/A * dclone() and store() is performed to memory. 1N/A (
"must supply result SV pointer for real recursion to memory"));
1N/A * Workaround for CROAK leak: if they enter with a "dirty" context, 1N/A * free up memory for them now. 1N/A * Now that STORABLE_xxx hooks exist, it is possible that they try to 1N/A * re-enter store() via the hooks. We need to stack contexts. 1N/A * Ensure sv is actually a reference. From perl, we called something 1N/A * pstore(aTHX_ FILE, \@array); 1N/A * so we must get the scalar value behing that reference. 1N/A sv =
SvRV(
sv);
/* So follow it to know what to store */ 1N/A * If we're going to store to memory, reset the buffer. 1N/A * Prepare context and emit headers. 1N/A return 0;
/* Error */ 1N/A * Recursively store object... 1N/A * If they asked for a memory store and they provided an SV pointer, 1N/A * make an SV string out of the buffer and fill their pointer. 1N/A * When asking for ST_REAL, it's MANDATORY for the caller to provide 1N/A * an SV, since context cleanup might free the buffer if we did recurse. 1N/A * (unless caller is dclone(), which is aware of that). 1N/A * The "root" context is never freed, since it is meant to be always 1N/A * handy for the common case where no recursion occurs at all (i.e. 1N/A * we enter store() outside of any Storable code and leave it, period). 1N/A * We know it's the "root" context because there's nothing stacked 1N/A * When deep cloning, we don't free the context: doing so would force 1N/A * us to copy the data in the memory buffer. Sicne we know we're 1N/A * about to enter do_retrieve... 1N/A * Store the transitive data closure of given object to disk. 1N/A * Returns 0 on error, a true value otherwise. 1N/A * Same as pstore(), but network order is used for integers and doubles are 1N/A * emitted as strings. 1N/A * Build a new SV out of the content of the internal memory buffer. 1N/A * Store the transitive data closure of given object to memory. 1N/A * Returns undef on error, a scalar value containing the data otherwise. 1N/A * Same as mstore(), but network order is used for integers and doubles are 1N/A * emitted as strings. 1N/A *** Specific retrieve callbacks. 1N/A * Return an error via croak, since it is not possible that we get here 1N/A * under normal conditions, when facing a file produced via pstore(). 1N/A CROAK((
"Corrupted storable %s (binary v%d.%d), current is v%d.%d",
1N/A CROAK((
"Corrupted storable %s (binary v%d.%d)",
1N/A return (
SV *) 0;
/* Just in case */ 1N/A * retrieve_idx_blessed 1N/A * Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read. 1N/A * <index> can be coded on either 1 or 5 bytes. 1N/A * Fetch classname in `aclass' 1N/A * Retrieve object and bless it. 1N/A * Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read. 1N/A * <len> can be coded on either 1 or 5 bytes. 1N/A * Decode class name length and read that name. 1N/A * Short classnames have two advantages: their length is stored on one 1N/A * single byte, and the string can be read on the stack. 1N/A * It's a new classname, otherwise it would have been an SX_IX_BLESS. 1N/A * Retrieve object and bless it. 1N/A * Layout: SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>] 1N/A * with leading mark already read, as usual. 1N/A * When recursion was involved during serialization of the object, there 1N/A * is an unknown amount of serialized objects after the SX_HOOK mark. Until 1N/A * we reach a <flags> marker with the recursion bit cleared. 1N/A * If the first <flags> byte contains a type of SHT_EXTRA, then the real type 1N/A * is held in the <extra> byte, and if the object is tied, the serialized 1N/A * magic object comes at the very end: 1N/A * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object> 1N/A * This means the STORABLE_thaw hook will NOT get a tied variable during its 1N/A * processing (since we won't have seen the magic object by the time the hook 1N/A * is called). See comments below for why it was done that way. 1N/A * Read flags, which tell us about the type, and whether we need to recurse. 1N/A * Create the (empty) object, and mark it as seen. 1N/A * This must be done now, because tags are incremented, and during 1N/A * serialization, the object tag was affected before recursion could 1N/A * Read <extra> flag to know the type of the object. 1N/A * Record associated magic type for later. 1N/A * Whilst flags tell us to recurse, do so. 1N/A * We don't need to remember the addresses returned by retrieval, because 1N/A * all the references will be obtained through indirection via the object 1N/A * tags in the object-ID list. 1N/A * We need to decrement the reference count for these objects 1N/A * because, if the user doesn't save a reference to them in the hook, 1N/A * they must be freed when this context is cleaned. 1N/A * Fetch index from `aclass' 1N/A * Decode class name length and read that name. 1N/A * NOTA BENE: even if the length is stored on one byte, we don't read 1N/A * on the stack. Just like retrieve_blessed(), we limit the name to 1N/A * LG_BLESS bytes. This is an arbitrary decision. 1N/A * Record new classname. 1N/A * Decode user-frozen string length and read it in an SV. 1N/A * For efficiency reasons, we read data directly into the SV buffer. 1N/A * To understand that code, read retrieve_scalar() 1N/A * Decode object-ID list length, if present. 1N/A * Read object-ID list into array. 1N/A * Because we pre-extended it, we can cheat and fill it manually. 1N/A * We read object tags and we can convert them into SV* on the fly 1N/A * because we know all the references listed in there (as tags) 1N/A * have been already serialized, hence we have a valid correspondance 1N/A * between each of those tags and the recreated SV. 1N/A for (i =
1; i <=
len3; i++) {
/* We leave [0] alone */ 1N/A /* av_fetch uses PL_sv_undef internally, hence this 1N/A somewhat gruesome hack. */ 1N/A CROAK((
"Object #%"IVdf" should have been retrieved already",
1N/A * Bless the object and look up the STORABLE_thaw hook. 1N/A * Hook not found. Maybe they did not require the module where this 1N/A * hook is defined yet? 1N/A * If the require below succeeds, we'll be able to find the hook. 1N/A * Still, it only works reliably when each class is defined in a 1N/A * We cache results of pkg_can, so we need to uncache before attempting 1N/A CROAK((
"No STORABLE_thaw defined for objects of class %s " 1N/A * If we don't have an `av' yet, prepare one. 1N/A * Then insert the frozen string as item [0]. 1N/A * $object->STORABLE_thaw($cloning, $frozen, @refs); 1N/A * where $object is our blessed (empty) object, $cloning is a boolean 1N/A * telling whether we're running a deep clone, $frozen is the frozen 1N/A * string the user gave us in his serializing hook, and @refs, which may 1N/A * be empty, is the list of extra references he returned along for us 1N/A * In effect, the hook is an alternate creation routine for the class, 1N/A * the object itself being already created by the runtime. 1N/A * If we had an <extra> type, then the object was not as simple, and 1N/A * we need to restore extra magic now. 1N/A * Adding the magic only now, well after the STORABLE_thaw hook was called 1N/A * means the hook cannot know it deals with an object whose variable is 1N/A * tied. But this is happening when retrieving $o in the following case: 1N/A * my $o = bless \%h, 'BAR'; 1N/A * The 'BAR' class is NOT the one where %h is tied into. Therefore, as 1N/A * far as the 'BAR' class is concerned, the fact that %h is not a REAL 1N/A * hash but a tied one should not matter at all, and remain transparent. 1N/A * This means the magic must be restored by Storable AFTER the hook is 1N/A * That looks very reasonable to me, but then I've come up with this 1N/A * after a bug report from David Nesting, who was trying to store such 1N/A * an object and caused Storable to fail. And unfortunately, it was 1N/A * also the easiest way to retrofit support for blessed ref to tied objects 1N/A * into the existing design. -- RAM, 17/02/2001 1N/A * Retrieve reference to some other scalar. 1N/A * Layout is SX_REF <object>, with SX_REF already read. 1N/A * We need to create the SV that holds the reference to the yet-to-retrieve 1N/A * object now, so that we may record the address in the seen table. 1N/A * Otherwise, if the object to retrieve references us, we won't be able 1N/A * to resolve the SX_OBJECT we'll see at that point! Hence we cannot 1N/A * do the retrieve first and use rv = newRV(sv) since it will be too late 1N/A * for SEEN() recording. 1N/A return (
SV *) 0;
/* Failed */ 1N/A * WARNING: breaks RV encapsulation. 1N/A * Now for the tricky part. We have to upgrade our existing SV, so that 1N/A * it is now an RV on sv... Again, we cheat by duplicating the code 1N/A * held in newSVrv(), since we already got our SV from retrieve(). 1N/A * SvRV(rv) = SvREFCNT_inc(sv); 1N/A * here because the reference count we got from retrieve() above is 1N/A * already correct: if the object was retrieved from the file, then 1N/A * its reference count is one. Otherwise, if it was retrieved via 1N/A * an SX_OBJECT indication, a ref count increment was done. 1N/A /* Do not use sv_upgrade to preserve STASH */ 1N/A * retrieve_overloaded 1N/A * Retrieve reference to some other scalar with overloading. 1N/A * Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read. 1N/A * Same code as retrieve_ref(), duplicated to avoid extra call. 1N/A return (
SV *) 0;
/* Failed */ 1N/A * WARNING: breaks RV encapsulation. 1N/A * Restore overloading magic. 1N/A ") (package <unknown>)",
1N/A ") (package %s) (even after a \"require %s;\")",
1N/A * retrieve_tied_array 1N/A * Retrieve tied array 1N/A * Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read. 1N/A return (
SV *) 0;
/* Failed */ 1N/A * retrieve_tied_hash 1N/A * Retrieve tied hash 1N/A * Layout is SX_TIED_HASH <object>, with SX_TIED_HASH already read. 1N/A return (
SV *) 0;
/* Failed */ 1N/A * retrieve_tied_scalar 1N/A * Retrieve tied scalar 1N/A * Layout is SX_TIED_SCALAR <object>, with SX_TIED_SCALAR already read. 1N/A return (
SV *) 0;
/* Failed */ 1N/A /* Undo refcnt inc from sv_magic() */ 1N/A * Retrieve reference to value in a tied hash. 1N/A * Layout is SX_TIED_KEY <object> <key>, with SX_TIED_KEY already read. 1N/A return (
SV *) 0;
/* Failed */ 1N/A return (
SV *) 0;
/* Failed */ 1N/A * Retrieve reference to value in a tied array. 1N/A * Layout is SX_TIED_IDX <object> <idx>, with SX_TIED_IDX already read. 1N/A return (
SV *) 0;
/* Failed */ 1N/A * Retrieve defined long (string) scalar. 1N/A * Layout is SX_LSCALAR <length> <data>, with SX_LSCALAR already read. 1N/A * The scalar is "long" in that <length> is larger than LG_SCALAR so it 1N/A * was not stored on a single byte. 1N/A * Allocate an empty scalar of the suitable length. 1N/A * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. 1N/A * Now, for efficiency reasons, read data directly inside the SV buffer, 1N/A * and perform the SV final settings directly by duplicating the final 1N/A * work done by sv_setpv. Since we're going to allocate lots of scalars 1N/A * this way, it's worth the hassle and risk. 1N/A *
SvEND(
sv) =
'\0';
/* Ensure it's null terminated anyway */ 1N/A * Retrieve defined short (string) scalar. 1N/A * Layout is SX_SCALAR <length> <data>, with SX_SCALAR already read. 1N/A * The scalar is "short" so <length> is single byte. If it is 0, there 1N/A * is no <data> section. 1N/A * Allocate an empty scalar of the suitable length. 1N/A * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. 1N/A * newSV did not upgrade to SVt_PV so the scalar is undefined. 1N/A * To make it defined with an empty length, upgrade it now... 1N/A * Don't upgrade to a PV if the original type contains more 1N/A * information than a scalar. 1N/A *
SvEND(
sv) =
'\0';
/* Ensure it's null terminated anyway */ 1N/A * Now, for efficiency reasons, read data directly inside the SV buffer, 1N/A * and perform the SV final settings directly by duplicating the final 1N/A * work done by sv_setpv. Since we're going to allocate lots of scalars 1N/A * this way, it's worth the hassle and risk. 1N/A *
SvEND(
sv) =
'\0';
/* Ensure it's null terminated anyway */ 1N/A * Like retrieve_scalar(), but tag result as utf8. 1N/A * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. 1N/A * Like retrieve_lscalar(), but tag result as utf8. 1N/A * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. 1N/A * Retrieve defined integer. 1N/A * Layout is SX_INTEGER <data>, whith SX_INTEGER already read. 1N/A * Retrieve defined integer in network order. 1N/A * Layout is SX_NETINT <data>, whith SX_NETINT already read. 1N/A * Retrieve defined double. 1N/A * Layout is SX_DOUBLE <data>, whith SX_DOUBLE already read. 1N/A * Retrieve defined byte (small integer within the [-128, +127] range). 1N/A * Layout is SX_BYTE <data>, whith SX_BYTE already read. 1N/A signed char tmp;
/* Workaround for AIX cc bug --H.Merijn Brand */ 1N/A * Return the undefined value. 1N/A * Return the immortal undefined value. 1N/A /* Special case PL_sv_undef, as av_fetch uses it internally to mark 1N/A deleted elements, and will return NULL (fetch failed) whenever it 1N/A * Return the immortal yes value. 1N/A * Return the immortal no value. 1N/A * Retrieve a whole array. 1N/A * Layout is SX_ARRAY <size> followed by each item, in increading index order. 1N/A * Each item is stored as <object>. 1N/A * When we come here, SX_ARRAY has been read already. 1N/A * Read length, and allocate array, then pre-extend it. 1N/A return (
SV *)
av;
/* No data follow if array is empty */ 1N/A * Now get each item in turn... 1N/A * Retrieve a whole hash table. 1N/A * Layout is SX_HASH <size> followed by each key/value pair, in random order. 1N/A * Keys are stored as <length> <data>, the <data> section being omitted 1N/A * Values are stored as <object>. 1N/A * When we come here, SX_HASH has been read already. 1N/A * Read length, allocate table. 1N/A return (
SV *)
hv;
/* No data follow if table empty */ 1N/A * Since we're reading into kbuf, we must ensure we're not 1N/A * recursing between the read and the hv_store() where it's used. 1N/A * Hence the key comes after the value. 1N/A * Retrieve a whole hash table. 1N/A * Layout is SX_HASH <size> followed by each key/value pair, in random order. 1N/A * Keys are stored as <length> <data>, the <data> section being omitted 1N/A * Values are stored as <object>. 1N/A * When we come here, SX_HASH has been read already. 1N/A * Read length, allocate table. 1N/A return (
SV *)
hv;
/* No data follow if table empty */ 1N/A /* XXX you can't set a placeholder with an SV key. 1N/A Then again, you can't get an SV key. 1N/A Without messing around beyond what the API is supposed to do. 1N/A * Since we're reading into kbuf, we must ensure we're not 1N/A * recursing between the read and the hv_store() where it's used. 1N/A * Hence the key comes after the value. 1N/A * Return a code reference. 1N/A CROAK((
"retrieve_code does not work with perl 5.005 or less\n"));
1N/A * Insert dummy SV in the aseen array so that we don't screw 1N/A * up the tag numbers. We would just make the internal 1N/A * scalar an untagged item in the stream, but 1N/A * retrieve_scalar() calls SEEN(). So we just increase the 1N/A * Retrieve the source of the code reference 1N/A * as a small or large scalar 1N/A * prepend "sub " to the source 1N/A * evaluate the source to a code reference and use the CV value 1N/A CROAK((
"Can't eval, please set $Storable::Eval to a true value"));
1N/A /* fix up the dummy entry... */ 1N/A CROAK((
"Unexpected return value from $Storable::Eval callback\n"));
1N/A /* fix up the dummy entry... */ 1N/A * old_retrieve_array 1N/A * Retrieve a whole array in pre-0.6 binary format. 1N/A * Layout is SX_ARRAY <size> followed by each item, in increading index order. 1N/A * Each item is stored as SX_ITEM <object> or SX_IT_UNDEF for "holes". 1N/A * When we come here, SX_ARRAY has been read already. 1N/A * Read length, and allocate array, then pre-extend it. 1N/A SEEN(
av, 0, 0);
/* Will return if array not allocated nicely */ 1N/A return (
SV *)
av;
/* No data follow if array is empty */ 1N/A * Now get each item in turn... 1N/A continue;
/* av_extend() already filled us with undef */ 1N/A * Retrieve a whole hash table in pre-0.6 binary format. 1N/A * Layout is SX_HASH <size> followed by each key/value pair, in random order. 1N/A * Keys are stored as SX_KEY <length> <data>, the <data> section being omitted 1N/A * Values are stored as SX_VALUE <object> or SX_VL_UNDEF for "holes". 1N/A * When we come here, SX_HASH has been read already. 1N/A * Read length, allocate table. 1N/A SEEN(
hv, 0, 0);
/* Will return if table not allocated properly */ 1N/A return (
SV *)
hv;
/* No data follow if table empty */ 1N/A * Due to a bug in hv_store(), it's not possible to pass 1N/A * &PL_sv_undef to hv_store() as a value, otherwise the 1N/A * associated key will not be creatable any more. -- RAM, 14/01/97 1N/A * Since we're reading into kbuf, we must ensure we're not 1N/A * recursing between the read and the hv_store() where it's used. 1N/A * Hence the key comes after the value. 1N/A *** Retrieval engine. 1N/A * Make sure the stored data we're trying to retrieve has been produced 1N/A * on an ILP compatible system with the same byteorder. It croaks out in 1N/A * case an error is detected. [ILP = integer-long-pointer sizes] 1N/A * Returns null if error is detected, &PL_sv_undef otherwise. 1N/A * Note that there's no byte ordering info emitted when network order was 1N/A * used at store time. 1N/A /* The worst case for a malicious header would be old magic (which is 1N/A longer), major, minor, byteorder length byte of 255, 255 bytes of 1N/A garbage, sizeof int, long, pointer, NV. 1N/A So the worse of that we can read is 255 bytes of garbage plus 4. 1N/A Err, I am assuming 8 bit bytes here. Please file a bug report if you're 1N/A compiling perl on a system with chars that are larger than 8 bits. 1N/A (Even Crays aren't *that* perverse). 1N/A * The "magic number" is only for files, not when freezing in memory. 1N/A /* This includes the '\0' at the end. I want to read the extra byte, 1N/A which is usually going to be the major version number. */ 1N/A /* Point at the byte after the byte we read. */ 1N/A * Try to read more bytes to check for the old magic number, which 1N/A * Starting with 0.6, the "use_network_order" byte flag is also used to 1N/A * indicate the version number of the binary, and therefore governs the 1N/A * setting of sv_retrieve_vtbl. See magic_write(). 1N/A * Starting with 0.7 (binary major 2), a full byte is dedicated to the 1N/A * minor version of the protocol. See magic_write(). 1N/A * Inter-operability sanity check: we can't retrieve something stored 1N/A * using a format more recent than ours, because we have no way to 1N/A * know what has changed, and letting retrieval go would mean a probable 1N/A * failure reporting a "corrupted" storable file. 1N/A CROAK((
"Storable binary image v%d.%d more recent than I am (v%d.%d)",
1N/A * If they stored using network order, there's no byte ordering 1N/A * information to check. 1N/A /* In C truth is 1, falsehood is 0. Very convienient. */ 1N/A /* No point in caching this in the context as we only need it once per 1N/A retrieve, and we need to recheck it each read. */ 1N/A CROAK((
"Byte order is not compatible"));
1N/A CROAK((
"Byte order is not compatible"));
1N/A CROAK((
"Integer size is not compatible"));
1N/A CROAK((
"Long integer size is not compatible"));
1N/A /* sizeof(char *) */ 1N/A CROAK((
"Pointer size is not compatible"));
1N/A CROAK((
"Double size is not compatible"));
1N/A * Recursively retrieve objects from the specified file and return their 1N/A * root SV (which may be an AV or an HV for what we care). 1N/A * Returns null if there is a problem. 1N/A * Grab address tag which identifies the object if we are retrieving 1N/A * an older format. Since the new binary format counts objects and no 1N/A * longer explicitely tags them, we must keep track of the correspondance 1N/A * The following section will disappear one day when the old format is 1N/A * no longer supported, hence the final "goto" in the "if" block. 1N/A * The following code is common with the SX_OBJECT case below. 1N/A CROAK((
"Object #%"IVdf" should have been retrieved already",
1N/A return sv;
/* The SV pointer where object was retrieved */ 1N/A * Map new object, but don't increase tagnum. This will be done 1N/A * by each of the retrieve_* functions when they call SEEN(). 1N/A * The mapping associates the "tag" initially present with a unique 1N/A * tag number. See test for SX_OBJECT above to see how this is perused. 1N/A * Regular post-0.6 binary format. 1N/A * Are we dealing with an object we should have already retrieved? 1N/A CROAK((
"Object #%"IVdf" should have been retrieved already",
1N/A return sv;
/* The SV pointer where object was retrieved */ 1N/A CROAK((
"Storable binary image v%d.%d contains data of type %d. " 1N/A "This Storable is v%d.%d and can only handle data types up to %d",
1N/Afirst_time:
/* Will disappear when support for old format is dropped */ 1N/A * Okay, first time through for this one. 1N/A return (
SV *) 0;
/* Failed */ 1N/A * Old binary formats (pre-0.7). 1N/A * Final notifications, ended by SX_STORED may now follow. 1N/A * Currently, the only pertinent notification to apply on the 1N/A * freshly retrieved object is either: 1N/A * SX_CLASS <char-len> <classname> for short classnames. 1N/A * SX_LG_CLASS <int-len> <classname> for larger one (rare!). 1N/A * Class name is then read into the key buffer pool used by 1N/A * hash table key retrieval. 1N/A return (
SV *) 0;
/* Failed */ 1N/A * Retrieve data held in file and return the root object. 1N/A * Common routine for pretrieve and mretrieve. 1N/A * Sanity assertions for retrieve dispatch tables. 1N/A (
"old and new retrieve dispatch table have same size"));
1N/A (
"SX_ERROR entry correctly initialized in old dispatch table"));
1N/A (
"SX_ERROR entry correctly initialized in new dispatch table"));
1N/A * Workaround for CROAK leak: if they enter with a "dirty" context, 1N/A * free up memory for them now. 1N/A * Now that STORABLE_xxx hooks exist, it is possible that they try to 1N/A * re-enter retrieve() via the hooks. 1N/A * Data is loaded into the memory buffer when f is NULL, unless `in' is 1N/A * also NULL, in which case we're expecting the data to already lie 1N/A * in the buffer (dclone case). 1N/A * Magic number verifications. 1N/A * This needs to be done before calling init_retrieve_context() 1N/A * since the format indication in the file are necessary to conduct 1N/A * some of the initializations. 1N/A CROAK((
"Magic number checking on storable %s failed",
1N/A * Check whether input source is tainted, so that we don't wrongly 1N/A * taint perfectly good values... 1N/A * We assume file input is always tainted. If both `f' and `in' are 1N/A * NULL, then we come from dclone, and tainted is already filled in 1N/A * the context. That's a kludge, but the whole dclone() thing is 1N/A * already quite a kludge anyway! -- RAM, 15/09/2000. 1N/A * The "root" context is never freed. 1N/A * Prepare returned value. 1N/A /* perl 5.00405 seems to screw up at this point with an 1N/A 'attempt to modify a read only value' error reported in the 1N/A eval { $self = pretrieve(*FILE) } in _retrieve. 1N/A I can't see what the cause of this error is, but I suspect a 1N/A bug in 5.004, as it seems to be capable of issuing spurious 1N/A errors or core dumping with matches on $@. I'm not going to 1N/A spend time on what could be a fruitless search for the cause, 1N/A so here's a bodge. If you're running 5.004 and don't like 1N/A this inefficiency, either upgrade to a newer perl, or you are 1N/A welcome to find the problem and send in a patch. 1N/A * Backward compatibility with Storable-0.5@9 (which we know we 1N/A * are retrieving if hseen is non-null): don't create an extra RV 1N/A * for objects since we special-cased it at store time. 1N/A * Build a reference to the SV returned by pretrieve even if it is 1N/A * already one and not a scalar, for consistency reasons. 1N/A TRACEME((
"ended do_retrieve() with an object -- pre 0.6"));
1N/A * If reference is overloaded, restore behaviour. 1N/A * NB: minor glitch here: normally, overloaded refs are stored specially 1N/A * so that we can croak when behaviour cannot be re-installed, and also 1N/A * avoid testing for overloading magic at each reference retrieval. 1N/A * Unfortunately, the root reference is implicitely stored, so we must 1N/A * check for possible overloading now. Furthermore, if we don't restore 1N/A * overloading, we cannot croak as if the original ref was, because we 1N/A * have no way to determine whether it was an overloaded ref or not in 1N/A * It's a pity that overloading magic is attached to the rv, and not to 1N/A * the underlying sv as blessing is. 1N/A TRACEME((
"restored overloading on root reference"));
1N/A * Retrieve data held in file and return the root object, undef on error. 1N/A * Retrieve data held in scalar and return the root object, undef on error. 1N/A * Deep clone: returns a fresh copy of the original referenced SV tree. 1N/A * This is achieved by storing the object in memory and restoring from 1N/A * there. Not that efficient, but it should be faster than doing it from 1N/A * Workaround for CROAK leak: if they enter with a "dirty" context, 1N/A * free up memory for them now. 1N/A * do_store() optimizes for dclone by not freeing its context, should 1N/A * we need to allocate one because we're deep cloning from a hook. 1N/A * Because of the above optimization, we have to refresh the context, 1N/A * since a new one could have been allocated and stacked by do_store(). 1N/A * Now, `cxt' may refer to a new context. 1N/A * Since we're passing do_retrieve() both a NULL file and sv, we need 1N/A * to pre-compute the taintedness of the input by setting cxt->tainted 1N/A * to whatever state our own input string was. -- RAM, 15/09/2000 1N/A * do_retrieve() will free non-root context. 1N/A * The Perl IO GV object distinguishes between input and output for sockets 1N/A * but not for plain files. To allow Storable to transparently work on 1N/A * plain files and sockets transparently, we have to ask xsubpp to fetch the 1N/A * right object for us. Hence the OutputStream and InputStream declarations. 1N/A * Before perl 5.004_05, those entries in the standard typemap are not 1N/A * defined in perl include files, so we do that here. 1N/A#
endif /* !OutputStream */ 1N/A /* Only disable the used only once warning if we are in debugging mode. */