X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FStorable%2FStorable.xs;h=24de05f88d24be8cf321a33f33c6a66b8c5ff543;hb=5e137bc214f9c21ed33df8110b67005fb915c4e7;hp=04e5c7ec56373c3ce1c3aa8a518f593b7af5a811;hpb=f062ea6c309fd04b801fe9bce80212a12094c21a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 04e5c7e..24de05f 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -1,74 +1,33 @@ /* - * Store and retrieve mechanism. - */ - -/* - * $Id: Storable.xs,v 1.0.1.10 2001/08/28 21:52:14 ram Exp $ + * Store and retrieve mechanism. * * Copyright (c) 1995-2000, Raphael Manfredi * * You may redistribute only under the same terms as Perl 5, as specified * in the README file that comes with the distribution. * - * $Log: Storable.xs,v $ - * Revision 1.0.1.10 2001/08/28 21:52:14 ram - * patch13: removed spurious debugging messages - * - * Revision 1.0.1.9 2001/07/01 11:25:02 ram - * patch12: fixed memory corruption on croaks during thaw() - * patch12: made code compile cleanly with -Wall (Jarkko Hietaniemi) - * patch12: changed tagnum and classnum from I32 to IV in context - * - * Revision 1.0.1.8 2001/03/15 00:20:55 ram - * patch11: last version was wrongly compiling with assertions on - * - * Revision 1.0.1.7 2001/02/17 12:25:26 ram - * patch8: now bless objects ASAP at retrieve time - * patch8: added support for blessed ref to tied structures - * - * Revision 1.0.1.6 2001/01/03 09:40:40 ram - * patch7: prototype and casting cleanup - * patch7: trace offending package when overloading cannot be restored - * patch7: made context cleanup safer to avoid dup freeing - * - * Revision 1.0.1.5 2000/11/05 17:21:24 ram - * patch6: fixed severe "object lost" bug for STORABLE_freeze returns - * - * Revision 1.0.1.4 2000/10/26 17:11:04 ram - * patch5: auto requires module of blessed ref when STORABLE_thaw misses - * - * Revision 1.0.1.3 2000/09/29 19:49:57 ram - * patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp - * - * Revision 1.0.1.2 2000/09/28 21:43:10 ram - * patch2: perls before 5.004_04 lack newSVpvn - * - * Revision 1.0.1.1 2000/09/17 16:47:49 ram - * patch1: now only taint retrieved data when source was tainted - * patch1: added support for UTF-8 strings - * patch1: fixed store hook bug: was allocating class id too soon - * - * Revision 1.0 2000/09/01 19:40:41 ram - * Baseline for first official release. - * */ +#define PERL_NO_GET_CONTEXT /* we want efficiency */ #include #include -#include /* Perl's one, needed since 5.6 */ #include -#ifndef NETWARE -#if 0 -#define DEBUGME /* Debug mode, turns assertions on as well */ -#define DASSERT /* Assertion mode */ +#ifndef PATCHLEVEL +#include /* Perl's one, needed since 5.6 */ +#endif + +#if !defined(PERL_VERSION) || PERL_VERSION < 8 +#define NEED_load_module +#define NEED_vload_module +#define NEED_newCONSTSUB +#include "ppport.h" /* handle old perls */ #endif -#else /* NETWARE */ -#if 0 /* On NetWare USE_PERLIO is not used */ + +#if 0 #define DEBUGME /* Debug mode, turns assertions on as well */ #define DASSERT /* Assertion mode */ #endif -#endif /* * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined @@ -130,6 +89,56 @@ typedef double NV; /* Older perls lack the NV type */ #endif #endif +#ifndef SvRV_set +#define SvRV_set(sv, val) \ + STMT_START { \ + assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*)SvANY(sv))->xrv_rv = (val)); \ + } STMT_END +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef dNOOP +#define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef dVAR +#define dVAR dNOOP +#endif + +#ifndef HvRITER_set +# define HvRITER_set(hv,r) (HvRITER(hv) = r) +#endif +#ifndef HvEITER_set +# define HvEITER_set(hv,r) (HvEITER(hv) = r) +#endif + +#ifndef HvRITER_get +# define HvRITER_get HvRITER +#endif +#ifndef HvEITER_get +# define HvEITER_get HvEITER +#endif + +#ifndef HvNAME_get +#define HvNAME_get HvNAME +#endif + +#ifndef HvPLACEHOLDERS_get +# define HvPLACEHOLDERS_get HvPLACEHOLDERS +#endif + #ifdef DEBUGME #ifndef DASSERT @@ -194,7 +203,10 @@ typedef double NV; /* Older perls lack the NV type */ #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_ERROR C(26) /* Error */ +#define SX_CODE C(26) /* Code references as perl source code */ +#define SX_WEAKREF C(27) /* Weak reference to object forthcoming */ +#define SX_WEAKOVERLOAD C(28) /* Overloaded weak reference */ +#define SX_ERROR C(29) /* Error */ /* * Those are only used to retrieve "old" pre-0.6 binary images. @@ -302,6 +314,9 @@ typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ #ifndef HAS_UTF8_ALL #define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl")) #endif +#ifndef SvWEAKREF +#define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl")) +#endif #ifdef HvPLACEHOLDERS #define HAS_RESTRICTED_HASHES @@ -314,18 +329,33 @@ typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ #define HAS_HASH_KEY_FLAGS #endif +#ifdef ptr_table_new +#define USE_PTR_TABLE +#endif + /* * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include * files remap tainted and dirty when threading is enabled. That's bad for * perl to remap such common words. -- RAM, 29/09/00 */ +struct stcxt; typedef struct stcxt { int entry; /* flags recursion */ int optype; /* type of traversal operation */ - HV *hseen; /* which objects have been seen, store time */ + /* which objects have been seen, store time. + tags are numbers, which are cast to (SV *) and stored directly */ +#ifdef USE_PTR_TABLE + /* use pseen if we have ptr_tables. We have to store tag+1, because + tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table + without it being confused for a fetch lookup failure. */ + struct ptr_tbl *pseen; + /* Still need hseen for the 0.6 file format code. */ +#endif + HV *hseen; AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */ AV *aseen; /* which objects have been seen, retrieve time */ + IV where_is_undef; /* index in aseen of PL_sv_undef */ HV *hclass; /* which classnames have been seen, store time */ AV *aclass; /* which classnames have been seen, retrieve time */ HV *hook; /* cache for hook methods per class name */ @@ -334,6 +364,8 @@ typedef struct stcxt { int netorder; /* true if network order used */ int s_tainted; /* true if input source is tainted, at retrieve time */ int forgive_me; /* whether to be forgiving... */ + int deparse; /* whether to deparse code refs */ + SV *eval; /* whether to eval source code */ int canonical; /* whether to store hashes sorted by key */ #ifndef HAS_RESTRICTED_HASHES int derestrict; /* whether to downgrade restrcted hashes */ @@ -350,7 +382,7 @@ typedef struct stcxt { 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)(); /* retrieve dispatch table */ + SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *); /* retrieve dispatch table */ SV *prev; /* contexts chained backwards in real recursion */ SV *my_sv; /* the blessed scalar who's SvPVX() I am */ } stcxt_t; @@ -359,7 +391,7 @@ typedef struct stcxt { STMT_START { \ SV *self = newSV(sizeof(stcxt_t) - 1); \ SV *my_sv = newRV_noinc(self); \ - sv_bless(my_sv, gv_stashpv("Storable::Cxt", TRUE)); \ + sv_bless(my_sv, gv_stashpv("Storable::Cxt", GV_ADD)); \ cxt = (stcxt_t *)SvPVX(self); \ Zero(cxt, 1, stcxt_t); \ cxt->my_sv = my_sv; \ @@ -378,7 +410,7 @@ typedef struct stcxt { #define dSTCXT_PTR(T,name) \ T name = ((perinterp_sv && SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \ - ? (T)SvPVX(SvRV((SV*)SvIVX(perinterp_sv))) : (T) 0)) + ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0)) #define dSTCXT \ dSTCXT_SV; \ dSTCXT_PTR(stcxt_t *, cxt) @@ -396,14 +428,14 @@ typedef struct stcxt { #else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */ -static stcxt_t Context; -static stcxt_t *Context_ptr = &Context; +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) + NEW_STORABLE_CXT_OBJ(cxt); \ + SET_STCXT(cxt) -#define SET_STCXT(x) Context_ptr = x #endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */ @@ -506,7 +538,7 @@ static stcxt_t *Context_ptr = &Context; if (!mbase) { \ TRACEME(("** allocating mbase of %d bytes", MGROW)); \ New(10003, mbase, MGROW, char); \ - msiz = MGROW; \ + msiz = (STRLEN)MGROW; \ } \ mptr = mbase; \ if (x) \ @@ -627,6 +659,17 @@ static stcxt_t *Context_ptr = &Context; } \ } 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) \ @@ -673,7 +716,8 @@ static stcxt_t *Context_ptr = &Context; #define svis_HASH 3 #define svis_TIED 4 #define svis_TIED_ITEM 5 -#define svis_OTHER 6 +#define svis_CODE 6 +#define svis_OTHER 7 /* * Flags for SX_HOOK. @@ -736,32 +780,97 @@ static stcxt_t *Context_ptr = &Context; * a "minor" version, to better track this kind of evolution from now on. * */ -static char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ -static char magicstr[] = "pst0"; /* Used as a magic number */ +static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ +static const char magicstr[] = "pst0"; /* Used as a magic number */ + +#define MAGICSTR_BYTES 'p','s','t','0' +#define OLDMAGICSTR_BYTES 'p','e','r','l','-','s','t','o','r','e' + +/* 5.6.x introduced the ability to have IVs as long long. + However, Configure still defined BYTEORDER based on the size of a long. + Storable uses the BYTEORDER value as part of the header, but doesn't + explicity store sizeof(IV) anywhere in the header. Hence on 5.6.x built + with IV as long long on a platform that uses Configure (ie most things + except VMS and Windows) headers are identical for the different IV sizes, + despite the files containing some fields based on sizeof(IV) + Erk. Broken-ness. + 5.8 is consistent - the following redifinition kludge is only needed on + 5.6.x, but the interwork is needed on 5.8 while data survives in files + with the 5.6 header. + +*/ + +#if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4) +#ifndef NO_56_INTERWORK_KLUDGE +#define USE_56_INTERWORK_KLUDGE +#endif +#if BYTEORDER == 0x1234 +#undef BYTEORDER +#define BYTEORDER 0x12345678 +#else +#if BYTEORDER == 0x4321 +#undef BYTEORDER +#define BYTEORDER 0x87654321 +#endif +#endif +#endif + +#if BYTEORDER == 0x1234 +#define BYTEORDER_BYTES '1','2','3','4' +#else +#if BYTEORDER == 0x12345678 +#define BYTEORDER_BYTES '1','2','3','4','5','6','7','8' +#ifdef USE_56_INTERWORK_KLUDGE +#define BYTEORDER_BYTES_56 '1','2','3','4' +#endif +#else +#if BYTEORDER == 0x87654321 +#define BYTEORDER_BYTES '8','7','6','5','4','3','2','1' +#ifdef USE_56_INTERWORK_KLUDGE +#define BYTEORDER_BYTES_56 '4','3','2','1' +#endif +#else +#if BYTEORDER == 0x4321 +#define BYTEORDER_BYTES '4','3','2','1' +#else +#error Unknown byteorder. Please append your byteorder to Storable.xs +#endif +#endif +#endif +#endif +static const char byteorderstr[] = {BYTEORDER_BYTES, 0}; +#ifdef USE_56_INTERWORK_KLUDGE +static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; +#endif #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ -#define STORABLE_BIN_MINOR 5 /* Binary minor "version" */ +#define STORABLE_BIN_MINOR 7 /* Binary minor "version" */ -/* If we aren't 5.7.3 or later, we won't be writing out files that use the - * new flagged hash introdued in 2.5, so put 2.4 in the binary header to - * maximise ease of interoperation with older Storables. - * Could we write 2.3s if we're on 5.005_03? NWC - */ -#if (PATCHLEVEL <= 6) +#if (PATCHLEVEL <= 5) #define STORABLE_BIN_WRITE_MINOR 4 #else -/* - * As of perl 5.7.3, utf8 hash key is introduced. - * So this must change -- dankogai +/* + * Perl 5.6.0 onwards can do weak references. */ -#define STORABLE_BIN_WRITE_MINOR 5 -#endif /* (PATCHLEVEL <= 6) */ +#define STORABLE_BIN_WRITE_MINOR 7 +#endif /* (PATCHLEVEL <= 5) */ + +#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1)) +#define PL_sv_placeholder PL_sv_undef +#endif /* * Useful store shortcuts... */ +/* + * Note that if you put more than one mark for storing a particular + * type of thing, *and* in the retrieve_foo() function you mark both + * the thingy's you get off with SEEN(), you *must* increase the + * tagnum with cxt->tagnum++ along with this macro! + * - samv 20Jan04 + */ #define PUTMARK(x) \ STMT_START { \ if (!cxt->fio) \ @@ -825,12 +934,12 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ #define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR) /* - * Store undef in arrays and hashes without recursing through store(). + * Store &PL_sv_undef in arrays without recursing through store(). */ -#define STORE_UNDEF() \ +#define STORE_SV_UNDEF() \ STMT_START { \ cxt->tagnum++; \ - PUTMARK(SX_UNDEF); \ + PUTMARK(SX_SV_UNDEF); \ } STMT_END /* @@ -891,6 +1000,16 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ } \ } STMT_END +#define SAFEPVREAD(x,y,z) \ + STMT_START { \ + if (!cxt->fio) \ + MBUF_SAFEPVREAD(x,y,z); \ + else if (PerlIO_read(cxt->fio, x, y) != y) { \ + Safefree(z); \ + return (SV *) 0; \ + } \ + } STMT_END + /* * This macro is used at retrieve time, to remember where object 'y', bearing a * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker, @@ -908,12 +1027,14 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ * To achieve that, the class name of the last retrieved object is passed down * recursively, and the first SEEN() call for which the class name is not NULL * will bless the object. + * + * i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef) */ -#define SEEN(y,c) \ +#define SEEN(y,c,i) \ STMT_START { \ if (!y) \ return (SV *) 0; \ - if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \ + if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) : SvREFCNT_inc(y)) == 0) \ return (SV *) 0; \ TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \ PTR2UV(y), SvREFCNT(y)-1)); \ @@ -929,37 +1050,71 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ SV *ref; \ HV *stash; \ TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \ - stash = gv_stashpv((p), TRUE); \ + stash = gv_stashpv((p), GV_ADD); \ ref = newRV_noinc(s); \ (void) sv_bless(ref, stash); \ - SvRV(ref) = 0; \ + SvRV_set(ref, NULL); \ SvREFCNT_dec(ref); \ } STMT_END +/* + * sort (used in store_hash) - conditionally use qsort when + * sortsv is not available ( <= 5.6.1 ). + */ + +#if (PATCHLEVEL <= 6) + +#if defined(USE_ITHREADS) -static int store(); -static SV *retrieve(stcxt_t *cxt, char *cname); +#define STORE_HASH_SORT \ + ENTER; { \ + PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \ + SAVESPTR(orig_perl); \ + PERL_SET_CONTEXT(aTHX); \ + qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); \ + } LEAVE; + +#else /* ! USE_ITHREADS */ + +#define STORE_HASH_SORT \ + qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); + +#endif /* USE_ITHREADS */ + +#else /* PATCHLEVEL > 6 */ + +#define STORE_HASH_SORT \ + sortsv(AvARRAY(av), len, Perl_sv_cmp); + +#endif /* PATCHLEVEL <= 6 */ + +static int store(pTHX_ stcxt_t *cxt, SV *sv); +static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname); /* * Dynamic dispatching table for SV store. */ -static int store_ref(stcxt_t *cxt, SV *sv); -static int store_scalar(stcxt_t *cxt, SV *sv); -static int store_array(stcxt_t *cxt, AV *av); -static int store_hash(stcxt_t *cxt, HV *hv); -static int store_tied(stcxt_t *cxt, SV *sv); -static int store_tied_item(stcxt_t *cxt, SV *sv); -static int store_other(stcxt_t *cxt, SV *sv); -static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg); - -static int (*sv_store[])(stcxt_t *cxt, SV *sv) = { - store_ref, /* svis_REF */ - store_scalar, /* svis_SCALAR */ - (int (*)(stcxt_t *cxt, SV *sv)) store_array, /* svis_ARRAY */ - (int (*)(stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */ - store_tied, /* svis_TIED */ - store_tied_item, /* svis_TIED_ITEM */ - store_other, /* svis_OTHER */ +static int store_ref(pTHX_ stcxt_t *cxt, SV *sv); +static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv); +static int store_array(pTHX_ stcxt_t *cxt, AV *av); +static int store_hash(pTHX_ stcxt_t *cxt, HV *hv); +static int store_tied(pTHX_ stcxt_t *cxt, SV *sv); +static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv); +static int store_code(pTHX_ stcxt_t *cxt, CV *cv); +static int store_other(pTHX_ stcxt_t *cxt, SV *sv); +static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg); + +typedef int (*sv_store_t)(pTHX_ stcxt_t *cxt, SV *sv); + +static const sv_store_t sv_store[] = { + (sv_store_t)store_ref, /* svis_REF */ + (sv_store_t)store_scalar, /* svis_SCALAR */ + (sv_store_t)store_array, /* svis_ARRAY */ + (sv_store_t)store_hash, /* svis_HASH */ + (sv_store_t)store_tied, /* svis_TIED */ + (sv_store_t)store_tied_item, /* svis_TIED_ITEM */ + (sv_store_t)store_code, /* svis_CODE */ + (sv_store_t)store_other, /* svis_OTHER */ }; #define SV_STORE(x) (*sv_store[x]) @@ -968,99 +1123,110 @@ static int (*sv_store[])(stcxt_t *cxt, SV *sv) = { * Dynamic dispatching tables for SV retrieval. */ -static SV *retrieve_lscalar(stcxt_t *cxt, char *cname); -static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname); -static SV *old_retrieve_array(stcxt_t *cxt, char *cname); -static SV *old_retrieve_hash(stcxt_t *cxt, char *cname); -static SV *retrieve_ref(stcxt_t *cxt, char *cname); -static SV *retrieve_undef(stcxt_t *cxt, char *cname); -static SV *retrieve_integer(stcxt_t *cxt, char *cname); -static SV *retrieve_double(stcxt_t *cxt, char *cname); -static SV *retrieve_byte(stcxt_t *cxt, char *cname); -static SV *retrieve_netint(stcxt_t *cxt, char *cname); -static SV *retrieve_scalar(stcxt_t *cxt, char *cname); -static SV *retrieve_utf8str(stcxt_t *cxt, char *cname); -static SV *retrieve_tied_array(stcxt_t *cxt, char *cname); -static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname); -static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname); -static SV *retrieve_other(stcxt_t *cxt, char *cname); - -static SV *(*sv_old_retrieve[])(stcxt_t *cxt, char *cname) = { +static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname); +static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname); +static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname); + +typedef SV* (*sv_retrieve_t)(pTHX_ stcxt_t *cxt, const char *name); + +static const sv_retrieve_t sv_old_retrieve[] = { 0, /* SX_OBJECT -- entry unused dynamically */ - retrieve_lscalar, /* SX_LSCALAR */ - old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ - old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */ - retrieve_ref, /* SX_REF */ - retrieve_undef, /* SX_UNDEF */ - retrieve_integer, /* SX_INTEGER */ - retrieve_double, /* SX_DOUBLE */ - retrieve_byte, /* SX_BYTE */ - retrieve_netint, /* SX_NETINT */ - retrieve_scalar, /* SX_SCALAR */ - retrieve_tied_array, /* SX_ARRAY */ - retrieve_tied_hash, /* SX_HASH */ - retrieve_tied_scalar, /* SX_SCALAR */ - retrieve_other, /* SX_SV_UNDEF not supported */ - retrieve_other, /* SX_SV_YES not supported */ - retrieve_other, /* SX_SV_NO not supported */ - retrieve_other, /* SX_BLESS not supported */ - retrieve_other, /* SX_IX_BLESS not supported */ - retrieve_other, /* SX_HOOK not supported */ - retrieve_other, /* SX_OVERLOADED not supported */ - retrieve_other, /* SX_TIED_KEY not supported */ - retrieve_other, /* SX_TIED_IDX not supported */ - retrieve_other, /* SX_UTF8STR not supported */ - retrieve_other, /* SX_LUTF8STR not supported */ - retrieve_other, /* SX_FLAG_HASH not supported */ - retrieve_other, /* SX_ERROR */ + (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ + (sv_retrieve_t)old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ + (sv_retrieve_t)old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */ + (sv_retrieve_t)retrieve_ref, /* SX_REF */ + (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ + (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ + (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ + (sv_retrieve_t)retrieve_byte, /* SX_BYTE */ + (sv_retrieve_t)retrieve_netint, /* SX_NETINT */ + (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ + (sv_retrieve_t)retrieve_tied_array, /* SX_ARRAY */ + (sv_retrieve_t)retrieve_tied_hash, /* SX_HASH */ + (sv_retrieve_t)retrieve_tied_scalar, /* SX_SCALAR */ + (sv_retrieve_t)retrieve_other, /* SX_SV_UNDEF not supported */ + (sv_retrieve_t)retrieve_other, /* SX_SV_YES not supported */ + (sv_retrieve_t)retrieve_other, /* SX_SV_NO not supported */ + (sv_retrieve_t)retrieve_other, /* SX_BLESS not supported */ + (sv_retrieve_t)retrieve_other, /* SX_IX_BLESS not supported */ + (sv_retrieve_t)retrieve_other, /* SX_HOOK not supported */ + (sv_retrieve_t)retrieve_other, /* SX_OVERLOADED not supported */ + (sv_retrieve_t)retrieve_other, /* SX_TIED_KEY not supported */ + (sv_retrieve_t)retrieve_other, /* SX_TIED_IDX not supported */ + (sv_retrieve_t)retrieve_other, /* SX_UTF8STR not supported */ + (sv_retrieve_t)retrieve_other, /* SX_LUTF8STR not supported */ + (sv_retrieve_t)retrieve_other, /* SX_FLAG_HASH not supported */ + (sv_retrieve_t)retrieve_other, /* SX_CODE not supported */ + (sv_retrieve_t)retrieve_other, /* SX_WEAKREF not supported */ + (sv_retrieve_t)retrieve_other, /* SX_WEAKOVERLOAD not supported */ + (sv_retrieve_t)retrieve_other, /* SX_ERROR */ }; -static SV *retrieve_array(stcxt_t *cxt, char *cname); -static SV *retrieve_hash(stcxt_t *cxt, char *cname); -static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname); -static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname); -static SV *retrieve_sv_no(stcxt_t *cxt, char *cname); -static SV *retrieve_blessed(stcxt_t *cxt, char *cname); -static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname); -static SV *retrieve_hook(stcxt_t *cxt, char *cname); -static SV *retrieve_overloaded(stcxt_t *cxt, char *cname); -static SV *retrieve_tied_key(stcxt_t *cxt, char *cname); -static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname); -static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname); - -static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = { +static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname); + +static const sv_retrieve_t sv_retrieve[] = { 0, /* SX_OBJECT -- entry unused dynamically */ - retrieve_lscalar, /* SX_LSCALAR */ - retrieve_array, /* SX_ARRAY */ - retrieve_hash, /* SX_HASH */ - retrieve_ref, /* SX_REF */ - retrieve_undef, /* SX_UNDEF */ - retrieve_integer, /* SX_INTEGER */ - retrieve_double, /* SX_DOUBLE */ - retrieve_byte, /* SX_BYTE */ - retrieve_netint, /* SX_NETINT */ - retrieve_scalar, /* SX_SCALAR */ - retrieve_tied_array, /* SX_ARRAY */ - retrieve_tied_hash, /* SX_HASH */ - retrieve_tied_scalar, /* SX_SCALAR */ - retrieve_sv_undef, /* SX_SV_UNDEF */ - retrieve_sv_yes, /* SX_SV_YES */ - retrieve_sv_no, /* SX_SV_NO */ - retrieve_blessed, /* SX_BLESS */ - retrieve_idx_blessed, /* SX_IX_BLESS */ - retrieve_hook, /* SX_HOOK */ - retrieve_overloaded, /* SX_OVERLOAD */ - retrieve_tied_key, /* SX_TIED_KEY */ - retrieve_tied_idx, /* SX_TIED_IDX */ - retrieve_utf8str, /* SX_UTF8STR */ - retrieve_lutf8str, /* SX_LUTF8STR */ - retrieve_flag_hash, /* SX_HASH */ - retrieve_other, /* SX_ERROR */ + (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ + (sv_retrieve_t)retrieve_array, /* SX_ARRAY */ + (sv_retrieve_t)retrieve_hash, /* SX_HASH */ + (sv_retrieve_t)retrieve_ref, /* SX_REF */ + (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ + (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ + (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ + (sv_retrieve_t)retrieve_byte, /* SX_BYTE */ + (sv_retrieve_t)retrieve_netint, /* SX_NETINT */ + (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ + (sv_retrieve_t)retrieve_tied_array, /* SX_ARRAY */ + (sv_retrieve_t)retrieve_tied_hash, /* SX_HASH */ + (sv_retrieve_t)retrieve_tied_scalar, /* SX_SCALAR */ + (sv_retrieve_t)retrieve_sv_undef, /* SX_SV_UNDEF */ + (sv_retrieve_t)retrieve_sv_yes, /* SX_SV_YES */ + (sv_retrieve_t)retrieve_sv_no, /* SX_SV_NO */ + (sv_retrieve_t)retrieve_blessed, /* SX_BLESS */ + (sv_retrieve_t)retrieve_idx_blessed, /* SX_IX_BLESS */ + (sv_retrieve_t)retrieve_hook, /* SX_HOOK */ + (sv_retrieve_t)retrieve_overloaded, /* SX_OVERLOAD */ + (sv_retrieve_t)retrieve_tied_key, /* SX_TIED_KEY */ + (sv_retrieve_t)retrieve_tied_idx, /* SX_TIED_IDX */ + (sv_retrieve_t)retrieve_utf8str, /* SX_UTF8STR */ + (sv_retrieve_t)retrieve_lutf8str, /* SX_LUTF8STR */ + (sv_retrieve_t)retrieve_flag_hash, /* SX_HASH */ + (sv_retrieve_t)retrieve_code, /* SX_CODE */ + (sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */ + (sv_retrieve_t)retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */ + (sv_retrieve_t)retrieve_other, /* SX_ERROR */ }; #define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)]) -static SV *mbuf2sv(void); +static SV *mbuf2sv(pTHX); /*** *** Context management. @@ -1071,12 +1237,13 @@ static SV *mbuf2sv(void); * * Called once per "thread" (interpreter) to initialize some global context. */ -static void init_perinterp(void) +static void init_perinterp(pTHX) { INIT_STCXT; cxt->netorder = 0; /* true if network order used */ cxt->forgive_me = -1; /* whether to be forgiving... */ + cxt->accept_future_minor = -1; /* would otherwise occur too late */ } /* @@ -1098,6 +1265,7 @@ static void reset_context(stcxt_t *cxt) * Initialize a new store context for real recursion. */ static void init_store_context( + pTHX_ stcxt_t *cxt, PerlIO *f, int optype, @@ -1107,6 +1275,8 @@ static void 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 */ @@ -1126,9 +1296,13 @@ static void init_store_context( * 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 @@ -1147,8 +1321,10 @@ static void init_store_context( */ #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 @@ -1190,7 +1366,7 @@ static void init_store_context( * * Clean store context by */ -static void clean_store_context(stcxt_t *cxt) +static void clean_store_context(pTHX_ stcxt_t *cxt) { HE *he; @@ -1202,11 +1378,13 @@ static void clean_store_context(stcxt_t *cxt) * Insert real values into hashes where we stored faked pointers. */ +#ifndef USE_PTR_TABLE if (cxt->hseen) { hv_iterinit(cxt->hseen); while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall, grr.. */ HeVAL(he) = &PL_sv_undef; } +#endif if (cxt->hclass) { hv_iterinit(cxt->hclass); @@ -1224,12 +1402,21 @@ static void clean_store_context(stcxt_t *cxt) * -- 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; @@ -1253,6 +1440,11 @@ static void clean_store_context(stcxt_t *cxt) } 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); @@ -1263,7 +1455,7 @@ static void clean_store_context(stcxt_t *cxt) * * Initialize a new retrieve context for real recursion. */ -static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) +static void init_retrieve_context(pTHX_ stcxt_t *cxt, int optype, int is_tainted) { TRACEME(("init_retrieve_context")); @@ -1278,6 +1470,10 @@ static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) 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 @@ -1285,9 +1481,11 @@ static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) * new retrieve routines. */ - cxt->hseen = ((cxt->retrieve_vtbl == sv_old_retrieve) ? newHV() : 0); + cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve) + ? newHV() : 0); cxt->aseen = newAV(); /* Where retrieved objects are kept */ + cxt->where_is_undef = -1; /* Special case for PL_sv_undef */ cxt->aclass = newAV(); /* Where seen classnames are kept */ cxt->tagnum = 0; /* Have to count objects... */ cxt->classnum = 0; /* ...and class names as well */ @@ -1308,7 +1506,7 @@ static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) * * Clean retrieve context by */ -static void clean_retrieve_context(stcxt_t *cxt) +static void clean_retrieve_context(pTHX_ stcxt_t *cxt) { TRACEME(("clean_retrieve_context")); @@ -1320,6 +1518,7 @@ static void clean_retrieve_context(stcxt_t *cxt) av_undef(aseen); sv_free((SV *) aseen); } + cxt->where_is_undef = -1; if (cxt->aclass) { AV *aclass = cxt->aclass; @@ -1358,7 +1557,7 @@ static void clean_retrieve_context(stcxt_t *cxt) * * A workaround for the CROAK bug: cleanup the last context. */ -static void clean_context(stcxt_t *cxt) +static void clean_context(pTHX_ stcxt_t *cxt) { TRACEME(("clean_context")); @@ -1370,9 +1569,9 @@ static void clean_context(stcxt_t *cxt) ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); if (cxt->optype & ST_RETRIEVE) - clean_retrieve_context(cxt); + clean_retrieve_context(aTHX_ cxt); else if (cxt->optype & ST_STORE) - clean_store_context(cxt); + clean_store_context(aTHX_ cxt); else reset_context(cxt); @@ -1386,8 +1585,7 @@ static void clean_context(stcxt_t *cxt) * 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(parent_cxt) -stcxt_t *parent_cxt; +static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt) { stcxt_t *cxt; @@ -1410,8 +1608,7 @@ stcxt_t *parent_cxt; * Free current context, which cannot be the "root" one. * Make the context underneath globally visible via SET_STCXT(). */ -static void free_context(cxt) -stcxt_t *cxt; +static void free_context(pTHX_ stcxt_t *cxt) { stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0); @@ -1435,7 +1632,7 @@ stcxt_t *cxt; * * Tells whether we're in the middle of a store operation. */ -int is_storing(void) +static int is_storing(pTHX) { dSTCXT; @@ -1447,7 +1644,7 @@ int is_storing(void) * * Tells whether we're in the middle of a retrieve operation. */ -int is_retrieving(void) +static int is_retrieving(pTHX) { dSTCXT; @@ -1462,7 +1659,7 @@ int is_retrieving(void) * This is typically out-of-band information that might prove useful * to people wishing to convert native to network order data when used. */ -int last_op_in_netorder(void) +static int last_op_in_netorder(pTHX) { dSTCXT; @@ -1482,12 +1679,15 @@ int last_op_in_netorder(void) * nor its ancestors know about the method. */ static SV *pkg_fetchmeth( + pTHX_ HV *cache, HV *pkg, - char *method) + const char *method) { GV *gv; SV *sv; + const char *hvname = HvNAME_get(pkg); + /* * The following code is the same as the one performed by UNIVERSAL::can @@ -1497,10 +1697,10 @@ static SV *pkg_fetchmeth( gv = gv_fetchmethod_autoload(pkg, method, FALSE); if (gv && isGV(gv)) { sv = newRV((SV*) GvCV(gv)); - TRACEME(("%s->%s: 0x%"UVxf, HvNAME(pkg), method, PTR2UV(sv))); + TRACEME(("%s->%s: 0x%"UVxf, hvname, method, PTR2UV(sv))); } else { sv = newSVsv(&PL_sv_undef); - TRACEME(("%s->%s: not found", HvNAME(pkg), method)); + TRACEME(("%s->%s: not found", hvname, method)); } /* @@ -1508,7 +1708,7 @@ static SV *pkg_fetchmeth( * it just won't be cached. */ - (void) hv_store(cache, HvNAME(pkg), strlen(HvNAME(pkg)), sv, 0); + (void) hv_store(cache, hvname, strlen(hvname), sv, 0); return SvOK(sv) ? sv : (SV *) 0; } @@ -1519,12 +1719,14 @@ static SV *pkg_fetchmeth( * Force cached value to be undef: hook ignored even if present. */ static void pkg_hide( + pTHX_ HV *cache, HV *pkg, - char *method) + const char *method) { + const char *hvname = HvNAME_get(pkg); (void) hv_store(cache, - HvNAME(pkg), strlen(HvNAME(pkg)), newSVsv(&PL_sv_undef), 0); + hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0); } /* @@ -1533,11 +1735,13 @@ static void pkg_hide( * Discard cached value: a whole fetch loop will be retried at next lookup. */ static void pkg_uncache( + pTHX_ HV *cache, HV *pkg, - char *method) + const char *method) { - (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD); + const char *hvname = HvNAME_get(pkg); + (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD); } /* @@ -1549,14 +1753,16 @@ static void pkg_uncache( * know about the method. */ static SV *pkg_can( + pTHX_ HV *cache, HV *pkg, - char *method) + const char *method) { SV **svh; SV *sv; + const char *hvname = HvNAME_get(pkg); - TRACEME(("pkg_can for %s->%s", HvNAME(pkg), method)); + TRACEME(("pkg_can for %s->%s", hvname, method)); /* * Look into the cache to see whether we already have determined @@ -1566,21 +1772,21 @@ static SV *pkg_can( * that only one hook (i.e. always the same) is cached in a given cache. */ - svh = hv_fetch(cache, HvNAME(pkg), strlen(HvNAME(pkg)), FALSE); + svh = hv_fetch(cache, hvname, strlen(hvname), FALSE); if (svh) { sv = *svh; if (!SvOK(sv)) { - TRACEME(("cached %s->%s: not found", HvNAME(pkg), method)); + TRACEME(("cached %s->%s: not found", hvname, method)); return (SV *) 0; } else { TRACEME(("cached %s->%s: 0x%"UVxf, - HvNAME(pkg), method, PTR2UV(sv))); + hvname, method, PTR2UV(sv))); return sv; } } TRACEME(("not cached yet")); - return pkg_fetchmeth(cache, pkg, method); /* Fetch and cache */ + return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */ } /* @@ -1590,6 +1796,7 @@ static SV *pkg_can( * Propagates the single returned value if not called in void context. */ static SV *scalar_call( + pTHX_ SV *obj, SV *hook, int cloning, @@ -1646,6 +1853,7 @@ static SV *scalar_call( * Returns the list of returned values in an array. */ static AV *array_call( + pTHX_ SV *obj, SV *hook, int cloning) @@ -1691,6 +1899,7 @@ static AV *array_call( * 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 */ @@ -1734,27 +1943,33 @@ static int known_class( * Store a reference. * Layout is SX_REF or SX_OVERLOAD . */ -static int store_ref(stcxt_t *cxt, SV *sv) +static int store_ref(pTHX_ stcxt_t *cxt, SV *sv) { + int is_weak = 0; TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv))); /* * Follow reference, and check if target is overloaded. */ +#ifdef SvWEAKREF + if (SvWEAKREF(sv)) + is_weak = 1; + TRACEME(("ref (0x%"UVxf") is%s weak", PTR2UV(sv), is_weak ? "" : "n't")); +#endif sv = SvRV(sv); if (SvOBJECT(sv)) { HV *stash = (HV *) SvSTASH(sv); if (stash && Gv_AMG(stash)) { TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv))); - PUTMARK(SX_OVERLOAD); + PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD); } else - PUTMARK(SX_REF); + PUTMARK(is_weak ? SX_WEAKREF : SX_REF); } else - PUTMARK(SX_REF); + PUTMARK(is_weak ? SX_WEAKREF : SX_REF); - return store(cxt, sv); + return store(aTHX_ cxt, sv); } /* @@ -1768,7 +1983,7 @@ static int store_ref(stcxt_t *cxt, SV *sv) * If integer or double, the layout is SX_INTEGER or SX_DOUBLE . * Small integers (within [-127, +127]) are stored as SX_BYTE . */ -static int store_scalar(stcxt_t *cxt, SV *sv) +static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv) { IV iv; char *pv; @@ -1836,89 +2051,134 @@ static int store_scalar(stcxt_t *cxt, SV *sv) pv = SvPV(sv, len); /* We know it's SvPOK */ goto string; /* Share code below */ } - } else if (flags & SVp_POK) { /* SvPOKp(sv) => string */ - I32 wlen; /* For 64-bit machines */ - pv = SvPV(sv, len); - - /* - * Will come here from below with pv and len set if double & netorder, - * or from above if it was readonly, POK and NOK but neither &PL_sv_yes - * nor &PL_sv_no. - */ - string: + } 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: - wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */ - if (SvUTF8 (sv)) - STORE_UTF8STR(pv, wlen); - else - STORE_SCALAR(pv, wlen); - TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")", - PTR2UV(sv), SvPVX(sv), (IV)len)); + /* 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). + */ - } else if (flags & SVp_NOK) { /* SvNOKp(sv) => double */ - NV nv = SvNV(sv); + if (iv >= -128 && iv <= 127) { + unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */ + PUTMARK(SX_BYTE); + PUTMARK(siv); + TRACEME(("small integer stored as %d", siv)); + } else if (cxt->netorder) { +#ifndef HAS_HTONL + TRACEME(("no htonl, fall back to string for integer")); + goto string_readlen; +#else + I32 niv; - /* - * Watch for number being an integer in disguise. - */ - if (nv == (NV) (iv = I_V(nv))) { - TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv)); - goto integer; /* Share code below */ - } - if (cxt->netorder) { - TRACEME(("double %"NVff" stored as string", nv)); - pv = SvPV(sv, len); - goto string; /* Share code above */ - } +#if IVSIZE > 4 + if ( +#ifdef SVf_IVisUV + /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ + ((flags & SVf_IVisUV) && SvUV(sv) > 0x7FFFFFFF) || +#endif + (iv > 0x7FFFFFFF) || (iv < -0x80000000)) { + /* Bigger than 32 bits. */ + TRACEME(("large network order integer as string, value = %"IVdf, iv)); + goto string_readlen; + } +#endif - PUTMARK(SX_DOUBLE); - WRITE(&nv, sizeof(nv)); + niv = (I32) htonl((I32) iv); + TRACEME(("using network order")); + PUTMARK(SX_NETINT); + WRITE_I32(niv); +#endif + } else { + PUTMARK(SX_INTEGER); + WRITE(&iv, sizeof(iv)); + } + + TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv)); + } else if (flags & SVf_NOK) { + NV nv; +#if (PATCHLEVEL <= 6) + nv = SvNV(sv); + /* + * Watch for number being an integer in disguise. + */ + if (nv == (NV) (iv = I_V(nv))) { + TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv)); + goto integer; /* Share code above */ + } +#else - TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv)); + SvIV_please(sv); + if (SvIOK_notUV(sv)) { + iv = SvIV(sv); + goto integer; /* Share code above */ + } + nv = SvNV(sv); +#endif - } else if (flags & SVp_IOK) { /* SvIOKp(sv) => integer */ - iv = SvIV(sv); + if (cxt->netorder) { + TRACEME(("double %"NVff" stored as string", nv)); + goto string_readlen; /* Share code below */ + } - /* - * Will come here from above with iv set if double is an integer. - */ - integer: + PUTMARK(SX_DOUBLE); + WRITE(&nv, sizeof(nv)); - /* - * Optimize small integers into a single byte, otherwise store as - * a real integer (converted into network order if they asked). - */ + TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv)); - if (iv >= -128 && iv <= 127) { - unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */ - PUTMARK(SX_BYTE); - PUTMARK(siv); - TRACEME(("small integer stored as %d", siv)); - } else if (cxt->netorder) { - I32 niv; -#ifdef HAS_HTONL - niv = (I32) htonl(iv); - TRACEME(("using network order")); -#else - niv = (I32) iv; - TRACEME(("as-is for network order")); -#endif - PUTMARK(SX_NETINT); - WRITE_I32(niv); - } else { - PUTMARK(SX_INTEGER); - WRITE(&iv, sizeof(iv)); - } + } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) { + I32 wlen; /* For 64-bit machines */ - TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv)); + string_readlen: + pv = SvPV(sv, len); + /* + * Will come here from above if it was readonly, POK and NOK but + * neither &PL_sv_yes nor &PL_sv_no. + */ + string: + + wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */ + if (SvUTF8 (sv)) + STORE_UTF8STR(pv, wlen); + else + STORE_SCALAR(pv, wlen); + TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")", + PTR2UV(sv), SvPVX(sv), (IV)len)); } else - CROAK(("Can't determine type of %s(0x%"UVxf")", - sv_reftype(sv, FALSE), - PTR2UV(sv))); - - return 0; /* Ok, no recursion on scalars */ + CROAK(("Can't determine type of %s(0x%"UVxf")", + sv_reftype(sv, FALSE), + PTR2UV(sv))); + return 0; /* Ok, no recursion on scalars */ } /* @@ -1929,7 +2189,7 @@ static int store_scalar(stcxt_t *cxt, SV *sv) * Layout is SX_ARRAY followed by each item, in increading index order. * Each item is stored as . */ -static int store_array(stcxt_t *cxt, AV *av) +static int store_array(pTHX_ stcxt_t *cxt, AV *av) { SV **sav; I32 len = av_len(av) + 1; @@ -1954,11 +2214,11 @@ static int store_array(stcxt_t *cxt, AV *av) sav = av_fetch(av, i, 0); if (!sav) { TRACEME(("(#%d) undef item", i)); - STORE_UNDEF(); + STORE_SV_UNDEF(); continue; } TRACEME(("(#%d) item", i)); - if ((ret = store(cxt, *sav))) /* Extra () for -Wall, grr... */ + if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall, grr... */ return ret; } @@ -1967,6 +2227,9 @@ static int store_array(stcxt_t *cxt, AV *av) return 0; } + +#if (PATCHLEVEL <= 6) + /* * sortcmp * @@ -1976,9 +2239,13 @@ static int store_array(stcxt_t *cxt, AV *av) static int sortcmp(const void *a, const void *b) { - return sv_cmp(*(SV * const *) a, *(SV * const *) b); +#if defined(USE_ITHREADS) + dTHX; +#endif /* USE_ITHREADS */ + return sv_cmp(*(SV * const *) a, *(SV * const *) b); } +#endif /* PATCHLEVEL <= 6 */ /* * store_hash @@ -2002,8 +2269,9 @@ sortcmp(const void *a, const void *b) * Currently the only hash flag is "restriced" * Key flags are as for hv.h */ -static int store_hash(stcxt_t *cxt, HV *hv) +static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) { + dVAR; I32 len = #ifdef HAS_RESTRICTED_HASHES HvTOTALKEYS(hv); @@ -2046,8 +2314,8 @@ static int store_hash(stcxt_t *cxt, HV *hv) * Save possible iteration state via each() on that table. */ - riter = HvRITER(hv); - eiter = HvEITER(hv); + riter = HvRITER_get(hv); + eiter = HvEITER_get(hv); hv_iterinit(hv); /* @@ -2085,22 +2353,55 @@ static int store_hash(stcxt_t *cxt, HV *hv) #else HE *he = hv_iternext(hv); #endif - SV *key = hv_iterkeysv(he); + SV *key; + + if (!he) + CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, len, i)); + key = hv_iterkeysv(he); av_store(av, AvFILLp(av)+1, key); /* av_push(), really */ } - qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); + STORE_HASH_SORT; for (i = 0; i < len; i++) { - unsigned char flags; +#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 = HeVAL(he); - if (val == 0) - return 1; /* Internal error, not I/O error */ + SV *val; + + if (he) { + if (!(val = HeVAL(he))) { + /* Internal error, not I/O error */ + return 1; + } + } else { +#ifdef HAS_RESTRICTED_HASHES + /* Should be a placeholder. */ + if (placeholders-- < 0) { + /* This should not happen - number of + retrieves should be identical to + number of placeholders. */ + return 1; + } + /* Value is never needed, and PL_sv_undef is + more space efficient to store. */ + val = &PL_sv_undef; + ASSERT (flags == 0, + ("Flags not 0 but %d", flags)); + flags = SHV_K_PLACEHOLDER; +#else + return 1; +#endif + } /* * Store value first. @@ -2108,7 +2409,7 @@ static int store_hash(stcxt_t *cxt, HV *hv) TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val))); - if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */ + if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */ goto out; /* @@ -2121,12 +2422,9 @@ static int store_hash(stcxt_t *cxt, HV *hv) /* Implementation of restricted hashes isn't nicely abstracted: */ - flags - = (((hash_flags & SHV_RESTRICTED) - && SvREADONLY(val)) - ? SHV_K_LOCKED : 0); - if (val == &PL_sv_undef) - flags |= SHV_K_PLACEHOLDER; + if ((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) { + flags |= SHV_K_LOCKED; + } keyval = SvPV(key, keylen_tmp); keylen = keylen_tmp; @@ -2166,7 +2464,13 @@ static int store_hash(stcxt_t *cxt, HV *hv) PUTMARK(flags); TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval)); } else { - assert (flags == 0); + /* This is a workaround for a bug in 5.8.0 + that causes the HEK_WASUTF8 flag to be + set on an HEK without the hash being + marked as having key flags. We just + cross our fingers and drop the flag. + AMS 20030901 */ + assert (flags == 0 || flags == SHV_K_WASUTF8); TRACEME(("(#%d) key '%s'", i, keyval)); } WLEN(keylen); @@ -2187,11 +2491,11 @@ static int store_hash(stcxt_t *cxt, HV *hv) /* * Storing in "random" order (in the order the keys are stored - * within the the hash). This is the default and will be faster! + * within the hash). This is the default and will be faster! */ for (i = 0; i < len; i++) { - char *key; + char *key = 0; I32 len; unsigned char flags; #ifdef HV_ITERNEXT_WANTPLACEHOLDERS @@ -2206,23 +2510,27 @@ static int store_hash(stcxt_t *cxt, HV *hv) if (val == 0) return 1; /* Internal error, not I/O error */ + /* Implementation of restricted hashes isn't nicely + abstracted: */ + flags + = (((hash_flags & SHV_RESTRICTED) + && SvREADONLY(val)) + ? SHV_K_LOCKED : 0); + + if (val == &PL_sv_placeholder) { + flags |= SHV_K_PLACEHOLDER; + val = &PL_sv_undef; + } + /* * Store value first. */ TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val))); - if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */ + if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */ goto out; - /* Implementation of restricted hashes isn't nicely - abstracted: */ - flags - = (((hash_flags & SHV_RESTRICTED) - && SvREADONLY(val)) - ? SHV_K_LOCKED : 0); - if (val == &PL_sv_undef) - flags |= SHV_K_PLACEHOLDER; hek = HeKEY_hek(he); len = HEK_LEN(hek); @@ -2257,11 +2565,17 @@ static int store_hash(stcxt_t *cxt, HV *hv) PUTMARK(flags); TRACEME(("(#%d) key '%s' flags %x", i, key, flags)); } else { - assert (flags == 0); + /* This is a workaround for a bug in 5.8.0 + that causes the HEK_WASUTF8 flag to be + set on an HEK without the hash being + marked as having key flags. We just + cross our fingers and drop the flag. + AMS 20030901 */ + assert (flags == 0 || flags == SHV_K_WASUTF8); TRACEME(("(#%d) key '%s'", i, key)); } if (flags & SHV_K_ISSV) { - store(cxt, key_sv); + store(aTHX_ cxt, key_sv); } else { WLEN(len); if (len) @@ -2273,13 +2587,118 @@ static int store_hash(stcxt_t *cxt, HV *hv) TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv))); out: - HvRITER(hv) = riter; /* Restore hash iterator state */ - HvEITER(hv) = eiter; + HvRITER_set(hv, riter); /* Restore hash iterator state */ + HvEITER_set(hv, eiter); return ret; } /* + * 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; + I32 len; + int count, reallen; + SV *text, *bdeparse; + + TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv))); + + if ( + cxt->deparse == 0 || + (cxt->deparse < 0 && !(cxt->deparse = + SvTRUE(perl_get_sv("Storable::Deparse", TRUE)) ? 1 : 0)) + ) { + return store_other(aTHX_ cxt, (SV*)cv); + } + + /* + * Require B::Deparse. At least B::Deparse 0.61 is needed for + * blessed code references. + */ + /* Ownership of both SVs is passed to load_module, which frees them. */ + load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61)); + SPAGAIN; + + ENTER; + SAVETMPS; + + /* + * create the B::Deparse object + */ + + PUSHMARK(sp); + XPUSHs(sv_2mortal(newSVpvn("B::Deparse",10))); + PUTBACK; + count = call_method("new", G_SCALAR); + SPAGAIN; + if (count != 1) + CROAK(("Unexpected return value from B::Deparse::new\n")); + bdeparse = POPs; + + /* + * call the coderef2text method + */ + + PUSHMARK(sp); + XPUSHs(bdeparse); /* XXX is this already mortal? */ + XPUSHs(sv_2mortal(newRV_inc((SV*)cv))); + PUTBACK; + count = call_method("coderef2text", G_SCALAR); + SPAGAIN; + if (count != 1) + CROAK(("Unexpected return value from B::Deparse::coderef2text\n")); + + text = POPs; + len = SvCUR(text); + reallen = strlen(SvPV_nolen(text)); + + /* + * Empty code references or XS functions are deparsed as + * "(prototype) ;" or ";". + */ + + if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') { + CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n")); + } + + /* + * Signal code by emitting SX_CODE. + */ + + PUTMARK(SX_CODE); + cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */ + TRACEME(("size = %d", len)); + TRACEME(("code = %s", SvPV_nolen(text))); + + /* + * Now store the source code. + */ + + STORE_SCALAR(SvPV_nolen(text), len); + + FREETMPS; + LEAVE; + + TRACEME(("ok (code)")); + + return 0; +#endif +} + +/* * store_tied * * When storing a tied object (be it a tied scalar, array or hash), we lay out @@ -2287,9 +2706,10 @@ out: * dealing with a tied hash, we store SX_TIED_HASH , where * stands for the serialization of the tied hash. */ -static int store_tied(stcxt_t *cxt, SV *sv) +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'; @@ -2335,7 +2755,9 @@ static int store_tied(stcxt_t *cxt, SV *sv) * accesses on the retrieved object will indeed call the magic methods... */ - if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ + /* [#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)")); @@ -2355,7 +2777,7 @@ static int store_tied(stcxt_t *cxt, SV *sv) * SX_TIED_KEY * SX_TIED_IDX */ -static int store_tied_item(stcxt_t *cxt, SV *sv) +static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv) { MAGIC *mg; int ret; @@ -2374,12 +2796,12 @@ static int store_tied_item(stcxt_t *cxt, SV *sv) PUTMARK(SX_TIED_KEY); TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj))); - if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ + 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(cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */ + if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */ return ret; } else { I32 idx = mg->mg_len; @@ -2388,7 +2810,7 @@ static int store_tied_item(stcxt_t *cxt, SV *sv) PUTMARK(SX_TIED_IDX); TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj))); - if ((ret = store(cxt, mg->mg_obj))) /* Idem, for -Wall */ + if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */ return ret; TRACEME(("store_tied_item: storing IDX %d", idx)); @@ -2447,6 +2869,7 @@ static int store_tied_item(stcxt_t *cxt, SV *sv) * any other tied variable. */ static int store_hook( + pTHX_ stcxt_t *cxt, SV *sv, int type, @@ -2454,7 +2877,7 @@ static int store_hook( SV *hook) { I32 len; - char *class; + char *classname; STRLEN len2; SV *ref; AV *av; @@ -2471,7 +2894,7 @@ static int store_hook( char mtype = '\0'; /* for blessed ref to tied structures */ unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */ - TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum)); + TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum)); /* * Determine object type on 2 bits. @@ -2522,8 +2945,8 @@ static int store_hook( } flags = SHF_NEED_RECURSE | obj_type; - class = HvNAME(pkg); - len = strlen(class); + classname = HvNAME_get(pkg); + len = strlen(classname); /* * To call the hook, we need to fake a call like: @@ -2538,11 +2961,11 @@ static int store_hook( * make the call on that reference. */ - TRACEME(("about to call STORABLE_freeze on class %s", class)); + TRACEME(("about to call STORABLE_freeze on class %s", classname)); ref = newRV_noinc(sv); /* Temporary reference */ - av = array_call(ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */ - SvRV(ref) = 0; + av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */ + SvRV_set(ref, NULL); SvREFCNT_dec(ref); /* Reclaim temporary reference */ count = AvFILLp(av) + 1; @@ -2562,16 +2985,16 @@ static int store_hook( * They must not change their mind in the middle of a serialization. */ - if (hv_fetch(cxt->hclass, class, len, FALSE)) + if (hv_fetch(cxt->hclass, classname, len, FALSE)) CROAK(("Too late to ignore hooks for %s class \"%s\"", - (cxt->optype & ST_CLONE) ? "cloning" : "storing", class)); + (cxt->optype & ST_CLONE) ? "cloning" : "storing", classname)); - pkg_hide(cxt->hook, pkg, "STORABLE_freeze"); + pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); - ASSERT(!pkg_can(cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible")); - TRACEME(("ignoring STORABLE_freeze in class \"%s\"", class)); + ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible")); + TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname)); - return store_blessed(cxt, sv, type, pkg); + return store_blessed(aTHX_ cxt, sv, type, pkg); } /* @@ -2580,12 +3003,22 @@ static int store_hook( ary = AvARRAY(av); pv = SvPV(ary[0], len2); + /* We can't use pkg_can here because it only caches one method per + * package */ + { + GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE); + if (gv && isGV(gv)) { + if (count > 1) + CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname)); + goto check_done; + } + } /* * If they returned more than one item, we need to serialize some * extra references if not already done. * - * Loop over the array, starting at postion #1, and for each item, + * 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. @@ -2595,23 +3028,37 @@ static int store_hook( */ for (i = 1; i < count; i++) { +#ifdef USE_PTR_TABLE + char *fake_tag; +#else SV **svh; +#endif SV *rsv = ary[i]; SV *xsv; + SV *tag; AV *av_hook = cxt->hook_seen; if (!SvROK(rsv)) CROAK(("Item #%d returned by STORABLE_freeze " - "for %s is not a reference", i, class)); + "for %s is not a reference", i, classname)); xsv = SvRV(rsv); /* Follow ref to know what to look for */ /* * Look in hseen and see if we have a tag already. * Serialize entry if not done already, and get its tag. */ - + +#ifdef USE_PTR_TABLE + /* Fakery needed because ptr_table_fetch returns zero for a + failure, whereas the existing code assumes that it can + safely store a tag zero. So for ptr_tables we store tag+1 + */ + if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv))) + goto sv_seen; /* Avoid moving code too far to the right */ +#else if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE))) goto sv_seen; /* Avoid moving code too far to the right */ +#endif TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv))); @@ -2635,13 +3082,18 @@ static int store_hook( } else PUTMARK(flags); - if ((ret = store(cxt, xsv))) /* Given by hook for us to store */ + if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */ return ret; +#ifdef USE_PTR_TABLE + fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv); + if (!sv) + CROAK(("Could not serialize item #%d from hook in %s", i, classname)); +#else svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE); if (!svh) - CROAK(("Could not serialize item #%d from hook in %s", i, class)); - + CROAK(("Could not serialize item #%d from hook in %s", i, classname)); +#endif /* * It was the first time we serialized `xsv'. * @@ -2671,9 +3123,14 @@ static int store_hook( * Replace entry with its tag (not a real SV, so no refcnt increment) */ - ary[i] = *svh; +#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(*svh))); + i-1, PTR2UV(xsv), PTR2UV(tag))); } /* @@ -2685,11 +3142,12 @@ static int store_hook( * proposed the right fix. -- RAM, 15/09/2000 */ - if (!known_class(cxt, class, len, &classnum)) { - TRACEME(("first time we see class %s, ID = %d", class, classnum)); +check_done: + if (!known_class(aTHX_ cxt, classname, len, &classnum)) { + TRACEME(("first time we see class %s, ID = %d", classname, classnum)); classnum = -1; /* Mark: we must store classname */ } else { - TRACEME(("already seen class %s, ID = %d", class, classnum)); + TRACEME(("already seen class %s, ID = %d", classname, classnum)); } /* @@ -2745,7 +3203,7 @@ static int store_hook( unsigned char clen = (unsigned char) len; PUTMARK(clen); } - WRITE(class, len); /* Final \0 is omitted */ + WRITE(classname, len); /* Final \0 is omitted */ } /* */ @@ -2812,7 +3270,7 @@ static int store_hook( * [] */ - if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ + if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ return ret; } @@ -2844,6 +3302,7 @@ static int store_hook( * on the high-order bit in flag (same encoding as above for ). */ static int store_blessed( + pTHX_ stcxt_t *cxt, SV *sv, int type, @@ -2851,29 +3310,29 @@ static int store_blessed( { SV *hook; I32 len; - char *class; + char *classname; I32 classnum; - TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME(pkg))); + 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(cxt->hook, pkg, "STORABLE_freeze"); + hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); if (hook) - return store_hook(cxt, sv, type, pkg, hook); + return store_hook(aTHX_ cxt, sv, type, pkg, hook); /* * This is a blessed SV without any serialization hook. */ - class = HvNAME(pkg); - len = strlen(class); + classname = HvNAME_get(pkg); + len = strlen(classname); TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d", - PTR2UV(sv), class, cxt->tagnum)); + PTR2UV(sv), classname, cxt->tagnum)); /* * Determine whether it is the first time we see that class name (in which @@ -2882,8 +3341,8 @@ static int store_blessed( * used). */ - if (known_class(cxt, class, len, &classnum)) { - TRACEME(("already seen class %s, ID = %d", class, classnum)); + if (known_class(aTHX_ cxt, classname, len, &classnum)) { + TRACEME(("already seen class %s, ID = %d", classname, classnum)); PUTMARK(SX_IX_BLESS); if (classnum <= LG_BLESS) { unsigned char cnum = (unsigned char) classnum; @@ -2894,7 +3353,7 @@ static int store_blessed( WLEN(classnum); } } else { - TRACEME(("first time we see class %s, ID = %d", class, classnum)); + TRACEME(("first time we see class %s, ID = %d", classname, classnum)); PUTMARK(SX_BLESS); if (len <= LG_BLESS) { unsigned char clen = (unsigned char) len; @@ -2904,14 +3363,14 @@ static int store_blessed( PUTMARK(flag); WLEN(len); /* Don't BER-encode, this should be rare */ } - WRITE(class, len); /* Final \0 is omitted */ + WRITE(classname, len); /* Final \0 is omitted */ } /* * Now emit the part. */ - return SV_STORE(type)(cxt, sv); + return SV_STORE(type)(aTHX_ cxt, sv); } /* @@ -2924,10 +3383,10 @@ static int store_blessed( * true value, then don't croak, just warn, and store a placeholder string * instead. */ -static int store_other(stcxt_t *cxt, SV *sv) +static int store_other(pTHX_ stcxt_t *cxt, SV *sv) { I32 len; - static char buf[80]; + char buf[80]; TRACEME(("store_other")); @@ -2954,7 +3413,7 @@ static int store_other(stcxt_t *cxt, SV *sv) len = strlen(buf); STORE_SCALAR(buf, len); - TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, len)); + TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, (IV) len)); return 0; } @@ -2971,11 +3430,13 @@ static int store_other(stcxt_t *cxt, SV *sv) * 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(SV *sv) +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 @@ -2983,7 +3444,11 @@ static int sv_type(SV *sv) */ return svis_SCALAR; case SVt_PV: +#if PERL_VERSION <= 10 case SVt_RV: +#else + case SVt_IV: +#endif case SVt_PVIV: case SVt_PVNV: /* @@ -3001,7 +3466,9 @@ static int sv_type(SV *sv) if (SvRMAGICAL(sv) && (mg_find(sv, 'p'))) return svis_TIED_ITEM; /* FALL THROUGH */ +#if PERL_VERSION < 9 case SVt_PVBM: +#endif if (SvRMAGICAL(sv) && (mg_find(sv, 'q'))) return svis_TIED; return SvROK(sv) ? svis_REF : svis_SCALAR; @@ -3013,6 +3480,11 @@ static int sv_type(SV *sv) if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) return svis_TIED; return svis_HASH; + case SVt_PVCV: + return svis_CODE; +#if PERL_VERSION > 8 + /* case SVt_BIND: */ +#endif default: break; } @@ -3029,12 +3501,16 @@ static int sv_type(SV *sv) * 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(stcxt_t *cxt, SV *sv) +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))); @@ -3045,14 +3521,54 @@ static int store(stcxt_t *cxt, SV *sv) * * 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 pobably safe to assume it is well under the 32-bit limit, + * That means it probably safe to assume it is well under the 32-bit limit, * and makes the truncation safe. * -- RAM, 14/09/1999 */ +#ifdef USE_PTR_TABLE + svh = (SV **)ptr_table_fetch(pseen, sv); +#else svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE); +#endif if (svh) { - I32 tagval = htonl(LOW_32BITS(*svh)); + I32 tagval; + + if (sv == &PL_sv_undef) { + /* We have seen PL_sv_undef before, but fake it as + if we have not. + + Not the simplest solution to making restricted + hashes work on 5.8.0, but it does mean that + repeated references to the one true undef will + take up less space in the output file. + */ + /* Need to jump past the next hv_store, because on the + second store of undef the old hash value will be + SvREFCNT_dec()ed, and as Storable cheats horribly + by storing non-SVs in the hash a SEGV will ensure. + Need to increase the tag number so that the + receiver has no idea what games we're up to. This + special casing doesn't affect hooks that store + undef, as the hook routine does its own lookup into + hseen. Also this means that any references back + to PL_sv_undef (from the pathological case of hooks + storing references to it) will find the seen hash + entry for the first time, as if we didn't have this + hackery here. (That hseen lookup works even on 5.8.0 + because it's a key of &PL_sv_undef and a value + which is a tag number, not a value which is + PL_sv_undef.) */ + cxt->tagnum++; + type = svis_SCALAR; + goto undef_special_case; + } + +#ifdef USE_PTR_TABLE + tagval = htonl(LOW_32BITS(((char *)svh)-1)); +#else + tagval = htonl(LOW_32BITS(*svh)); +#endif TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval))); @@ -3073,25 +3589,30 @@ static int store(stcxt_t *cxt, SV *sv) */ 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(sv); + type = sv_type(aTHX_ sv); +undef_special_case: TRACEME(("storing 0x%"UVxf" tag #%d, type %d...", PTR2UV(sv), cxt->tagnum, type)); if (SvOBJECT(sv)) { HV *pkg = SvSTASH(sv); - ret = store_blessed(cxt, sv, type, pkg); + ret = store_blessed(aTHX_ cxt, sv, type, pkg); } else - ret = SV_STORE(type)(cxt, sv); + ret = SV_STORE(type)(aTHX_ cxt, sv); TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)", ret ? "FAILED" : "ok", PTR2UV(sv), @@ -3111,54 +3632,89 @@ static int store(stcxt_t *cxt, SV *sv) * 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(stcxt_t *cxt) +static int magic_write(pTHX_ stcxt_t *cxt) { - char buf[256]; /* Enough room for 256 hexa digits */ - unsigned char c; - int use_network_order = cxt->netorder; - - TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) - : -1)); - - if (cxt->fio) - WRITE(magicstr, (SSize_t)strlen(magicstr)); /* Don't write final \0 */ - - /* - * 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. - */ - - c = (unsigned char) - ((use_network_order ? 0x1 : 0x0) | (STORABLE_BIN_MAJOR << 1)); - PUTMARK(c); - - /* - * 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. - */ + /* + * 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. + */ - PUTMARK((unsigned char) STORABLE_BIN_WRITE_MINOR); + /* Make these at compile time. The WRITE() macro is sufficiently complex + that it saves about 200 bytes doing it this way and only using it + once. */ + static const unsigned char network_file_header[] = { + MAGICSTR_BYTES, + (STORABLE_BIN_MAJOR << 1) | 1, + STORABLE_BIN_WRITE_MINOR + }; + static const unsigned char file_header[] = { + MAGICSTR_BYTES, + (STORABLE_BIN_MAJOR << 1) | 0, + STORABLE_BIN_WRITE_MINOR, + /* sizeof the array includes the 0 byte at the end: */ + (char) sizeof (byteorderstr) - 1, + BYTEORDER_BYTES, + (unsigned char) sizeof(int), + (unsigned char) sizeof(long), + (unsigned char) sizeof(char *), + (unsigned char) sizeof(NV) + }; +#ifdef USE_56_INTERWORK_KLUDGE + static const unsigned char file_header_56[] = { + MAGICSTR_BYTES, + (STORABLE_BIN_MAJOR << 1) | 0, + STORABLE_BIN_WRITE_MINOR, + /* sizeof the array includes the 0 byte at the end: */ + (char) sizeof (byteorderstr_56) - 1, + BYTEORDER_BYTES_56, + (unsigned char) sizeof(int), + (unsigned char) sizeof(long), + (unsigned char) sizeof(char *), + (unsigned char) sizeof(NV) + }; +#endif + const unsigned char *header; + SSize_t length; + + TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) : -1)); + + if (cxt->netorder) { + header = network_file_header; + length = sizeof (network_file_header); + } else { +#ifdef USE_56_INTERWORK_KLUDGE + if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) { + header = file_header_56; + length = sizeof (file_header_56); + } else +#endif + { + header = file_header; + length = sizeof (file_header); + } + } - if (use_network_order) - return 0; /* Don't bother with byte ordering */ + if (!cxt->fio) { + /* sizeof the array includes the 0 byte at the end. */ + header += sizeof (magicstr) - 1; + length -= sizeof (magicstr) - 1; + } - sprintf(buf, "%lx", (unsigned long) BYTEORDER); - c = (unsigned char) strlen(buf); - PUTMARK(c); - WRITE(buf, (SSize_t)c); /* Don't write final \0 */ - PUTMARK((unsigned char) sizeof(int)); - PUTMARK((unsigned char) sizeof(long)); - PUTMARK((unsigned char) sizeof(char *)); - PUTMARK((unsigned char) sizeof(NV)); + 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) c, + (unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1, (int) sizeof(int), (int) sizeof(long), (int) sizeof(char *), (int) sizeof(NV))); - - return 0; + } + return 0; } /* @@ -3173,6 +3729,7 @@ static int magic_write(stcxt_t *cxt) * dclone() and store() is performed to memory. */ static int do_store( + pTHX_ PerlIO *f, SV *sv, int optype, @@ -3196,7 +3753,7 @@ static int do_store( */ if (cxt->s_dirty) - clean_context(cxt); + clean_context(aTHX_ cxt); /* * Now that STORABLE_xxx hooks exist, it is possible that they try to @@ -3204,7 +3761,7 @@ static int do_store( */ if (cxt->entry) - cxt = allocate_context(cxt); + cxt = allocate_context(aTHX_ cxt); cxt->entry++; @@ -3214,7 +3771,7 @@ static int do_store( /* * Ensure sv is actually a reference. From perl, we called something * like: - * pstore(FILE, \@array); + * pstore(aTHX_ FILE, \@array); * so we must get the scalar value behing that reference. */ @@ -3233,18 +3790,18 @@ static int do_store( * Prepare context and emit headers. */ - init_store_context(cxt, f, optype, network_order); + init_store_context(aTHX_ cxt, f, optype, network_order); - if (-1 == magic_write(cxt)) /* Emit magic and ILP info */ + if (-1 == magic_write(aTHX_ cxt)) /* Emit magic and ILP info */ return 0; /* Error */ /* * Recursively store object... */ - ASSERT(is_storing(), ("within store operation")); + ASSERT(is_storing(aTHX), ("within store operation")); - status = store(cxt, sv); /* Just do it! */ + status = store(aTHX_ cxt, sv); /* Just do it! */ /* * If they asked for a memory store and they provided an SV pointer, @@ -3256,7 +3813,7 @@ static int do_store( */ if (!cxt->fio && res) - *res = mbuf2sv(); + *res = mbuf2sv(aTHX); /* * Final cleanup. @@ -3274,9 +3831,9 @@ static int do_store( * about to enter do_retrieve... */ - clean_store_context(cxt); + clean_store_context(aTHX_ cxt); if (cxt->prev && !(cxt->optype & ST_CLONE)) - free_context(cxt); + free_context(aTHX_ cxt); TRACEME(("do_store returns %d", status)); @@ -3289,10 +3846,10 @@ static int do_store( * Store the transitive data closure of given object to disk. * Returns 0 on error, a true value otherwise. */ -int pstore(PerlIO *f, SV *sv) +static int pstore(pTHX_ PerlIO *f, SV *sv) { TRACEME(("pstore")); - return do_store(f, sv, 0, FALSE, (SV**) 0); + return do_store(aTHX_ f, sv, 0, FALSE, (SV**) 0); } @@ -3302,10 +3859,10 @@ int pstore(PerlIO *f, SV *sv) * Same as pstore(), but network order is used for integers and doubles are * emitted as strings. */ -int net_pstore(PerlIO *f, SV *sv) +static int net_pstore(pTHX_ PerlIO *f, SV *sv) { TRACEME(("net_pstore")); - return do_store(f, sv, 0, TRUE, (SV**) 0); + return do_store(aTHX_ f, sv, 0, TRUE, (SV**) 0); } /*** @@ -3317,7 +3874,7 @@ int net_pstore(PerlIO *f, SV *sv) * * Build a new SV out of the content of the internal memory buffer. */ -static SV *mbuf2sv(void) +static SV *mbuf2sv(pTHX) { dSTCXT; @@ -3330,13 +3887,13 @@ static SV *mbuf2sv(void) * Store the transitive data closure of given object to memory. * Returns undef on error, a scalar value containing the data otherwise. */ -SV *mstore(SV *sv) +static SV *mstore(pTHX_ SV *sv) { SV *out; TRACEME(("mstore")); - if (!do_store((PerlIO*) 0, sv, 0, FALSE, &out)) + if (!do_store(aTHX_ (PerlIO*) 0, sv, 0, FALSE, &out)) return &PL_sv_undef; return out; @@ -3348,13 +3905,13 @@ SV *mstore(SV *sv) * Same as mstore(), but network order is used for integers and doubles are * emitted as strings. */ -SV *net_mstore(SV *sv) +static SV *net_mstore(pTHX_ SV *sv) { SV *out; TRACEME(("net_mstore")); - if (!do_store((PerlIO*) 0, sv, 0, TRUE, &out)) + if (!do_store(aTHX_ (PerlIO*) 0, sv, 0, TRUE, &out)) return &PL_sv_undef; return out; @@ -3370,7 +3927,7 @@ SV *net_mstore(SV *sv) * 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(stcxt_t *cxt, char *cname) +static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname) { if ( cxt->ver_major != STORABLE_BIN_MAJOR && @@ -3395,10 +3952,10 @@ static SV *retrieve_other(stcxt_t *cxt, char *cname) * 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(stcxt_t *cxt, char *cname) +static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname) { I32 idx; - char *class; + const char *classname; SV **sva; SV *sv; @@ -3417,15 +3974,15 @@ static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname) if (!sva) CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx)); - class = SvPVX(*sva); /* We know it's a PV, by construction */ + classname = SvPVX(*sva); /* We know it's a PV, by construction */ - TRACEME(("class ID %d => %s", idx, class)); + TRACEME(("class ID %d => %s", idx, classname)); /* * Retrieve object and bless it. */ - sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */ + sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */ return sv; } @@ -3436,12 +3993,13 @@ static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname) * Layout is SX_BLESS with SX_BLESS already read. * can be coded on either 1 or 5 bytes. */ -static SV *retrieve_blessed(stcxt_t *cxt, char *cname) +static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname) { I32 len; SV *sv; char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ - char *class = buf; + char *classname = buf; + char *malloced_classname = NULL; TRACEME(("retrieve_blessed (#%d)", cxt->tagnum)); ASSERT(!cname, ("no bless-into class given here, got %s", cname)); @@ -3457,27 +4015,30 @@ static SV *retrieve_blessed(stcxt_t *cxt, char *cname) if (len & 0x80) { RLEN(len); TRACEME(("** allocating %d bytes for class name", len+1)); - New(10003, class, len+1, char); + New(10003, classname, len+1, char); + malloced_classname = classname; } - READ(class, len); - class[len] = '\0'; /* Mark string end */ + SAFEPVREAD(classname, len, malloced_classname); + classname[len] = '\0'; /* Mark string end */ /* * It's a new classname, otherwise it would have been an SX_IX_BLESS. */ - TRACEME(("new class name \"%s\" will bear ID = %d", class, cxt->classnum)); + TRACEME(("new class name \"%s\" will bear ID = %d", classname, cxt->classnum)); - if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len))) + if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) { + Safefree(malloced_classname); return (SV *) 0; + } /* * Retrieve object and bless it. */ - sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */ - if (class != buf) - Safefree(class); + sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */ + if (malloced_classname) + Safefree(malloced_classname); return sv; } @@ -3502,11 +4063,11 @@ static SV *retrieve_blessed(stcxt_t *cxt, char *cname) * 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(stcxt_t *cxt, char *cname) +static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname) { I32 len; char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ - char *class = buf; + char *classname = buf; unsigned int flags; I32 len2; SV *frozen; @@ -3515,6 +4076,7 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) SV *hook; SV *sv; SV *rv; + GV *attach; int obj_type; int clone = cxt->optype & ST_CLONE; char mtype = '\0'; @@ -3568,13 +4130,13 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) mtype = 'P'; break; default: - return retrieve_other(cxt, 0); /* Let it croak */ + return retrieve_other(aTHX_ cxt, 0); /* Let it croak */ } break; default: - return retrieve_other(cxt, 0); /* Let it croak */ + return retrieve_other(aTHX_ cxt, 0); /* Let it croak */ } - SEEN(sv, 0); /* Don't bless yet */ + SEEN(sv, 0, 0); /* Don't bless yet */ /* * Whilst flags tell us to recurse, do so. @@ -3582,13 +4144,18 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) * 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(cxt, 0); + 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); @@ -3612,8 +4179,8 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx)); - class = SvPVX(*sva); /* We know it's a PV, by construction */ - TRACEME(("class ID %d => %s", idx, class)); + classname = SvPVX(*sva); /* We know it's a PV, by construction */ + TRACEME(("class ID %d => %s", idx, classname)); } else { /* @@ -3623,6 +4190,7 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) * 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); @@ -3631,21 +4199,24 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) if (len > LG_BLESS) { TRACEME(("** allocating %d bytes for class name", len+1)); - New(10003, class, len+1, char); + New(10003, classname, len+1, char); + malloced_classname = classname; } - READ(class, len); - class[len] = '\0'; /* Mark string end */ + SAFEPVREAD(classname, len, malloced_classname); + classname[len] = '\0'; /* Mark string end */ /* * Record new classname. */ - if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len))) + if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) { + Safefree(malloced_classname); return (SV *) 0; + } } - TRACEME(("class name: %s", class)); + TRACEME(("class name: %s", classname)); /* * Decode user-frozen string length and read it in an SV. @@ -3710,9 +4281,17 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) READ_I32(tag); tag = ntohl(tag); svh = av_fetch(cxt->aseen, tag, FALSE); - if (!svh) - CROAK(("Object #%"IVdf" should have been retrieved already", - (IV) tag)); + 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); } @@ -3722,38 +4301,56 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) * Bless the object and look up the STORABLE_thaw hook. */ - BLESS(sv, class); - hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw"); + BLESS(sv, classname); + + /* Handle attach case; again can't use pkg_can because it only + * caches one method */ + attach = gv_fetchmethod_autoload(SvSTASH(sv), "STORABLE_attach", FALSE); + if (attach && isGV(attach)) { + SV* attached; + SV* attach_hook = newRV((SV*) GvCV(attach)); + + if (av) + CROAK(("STORABLE_attach called with unexpected references")); + av = newAV(); + av_extend(av, 1); + AvFILLp(av) = 0; + AvARRAY(av)[0] = SvREFCNT_inc(frozen); + rv = newSVpv(classname, 0); + attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR); + if (attached && + SvROK(attached) && + sv_derived_from(attached, classname)) + return SvRV(attached); + CROAK(("STORABLE_attach did not return a %s object", classname)); + } + + hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); if (!hook) { /* * Hook not found. Maybe they did not require the module where this * hook is defined yet? * - * If the require below succeeds, we'll be able to find the hook. + * 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. */ - SV *psv = newSVpvn("require ", 8); - sv_catpv(psv, class); - - TRACEME(("No STORABLE_thaw defined for objects of class %s", class)); - TRACEME(("Going to require module '%s' with '%s'", class, SvPVX(psv))); - - perl_eval_sv(psv, G_DISCARD); - sv_free(psv); + 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(cxt->hook, SvSTASH(sv), "STORABLE_thaw"); - hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw"); + 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;\")", class, class)); + "(even after a \"require %s;\")", classname, classname)); } /* @@ -3784,10 +4381,10 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) */ TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)", - class, PTR2UV(sv), AvFILLp(av) + 1)); + classname, PTR2UV(sv), (IV) AvFILLp(av) + 1)); rv = newRV(sv); - (void) scalar_call(rv, hook, clone, av, G_SCALAR|G_DISCARD); + (void) scalar_call(aTHX_ rv, hook, clone, av, G_SCALAR|G_DISCARD); SvREFCNT_dec(rv); /* @@ -3797,8 +4394,8 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) SvREFCNT_dec(frozen); av_undef(av); sv_free((SV *) av); - if (!(flags & SHF_IDX_CLASSNAME) && class != buf) - Safefree(class); + if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) + Safefree(classname); /* * If we had an type, then the object was not as simple, and @@ -3810,7 +4407,7 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv))); - rv = retrieve(cxt, 0); /* Retrieve */ + rv = retrieve(aTHX_ cxt, 0); /* Retrieve */ TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf, PTR2UV(rv), PTR2UV(sv))); @@ -3853,7 +4450,7 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) * into the existing design. -- RAM, 17/02/2001 */ - sv_magic(sv, rv, mtype, Nullch, 0); + sv_magic(sv, rv, mtype, (char *)NULL, 0); SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */ return sv; @@ -3865,7 +4462,7 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) * Retrieve reference to some other scalar. * Layout is SX_REF , with SX_REF already read. */ -static SV *retrieve_ref(stcxt_t *cxt, char *cname) +static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname) { SV *rv; SV *sv; @@ -3882,8 +4479,8 @@ static SV *retrieve_ref(stcxt_t *cxt, char *cname) */ rv = NEWSV(10002, 0); - SEEN(rv, cname); /* Will return if rv is null */ - sv = retrieve(cxt, 0); /* Retrieve */ + SEEN(rv, cname, 0); /* Will return if rv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ @@ -3904,8 +4501,14 @@ static SV *retrieve_ref(stcxt_t *cxt, char *cname) * an SX_OBJECT indication, a ref count increment was done. */ - sv_upgrade(rv, SVt_RV); - SvRV(rv) = sv; /* $rv = \$sv */ + if (cname) { + /* No need to do anything, as rv will already be PVMG. */ + assert (SvTYPE(rv) == SVt_RV || SvTYPE(rv) >= SVt_PV); + } else { + sv_upgrade(rv, SVt_RV); + } + + SvRV_set(rv, sv); /* $rv = \$sv */ SvROK_on(rv); TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv))); @@ -3914,12 +4517,35 @@ static SV *retrieve_ref(stcxt_t *cxt, char *cname) } /* + * 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)", 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(stcxt_t *cxt, char *cname) +static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname) { SV *rv; SV *sv; @@ -3932,8 +4558,8 @@ static SV *retrieve_overloaded(stcxt_t *cxt, char *cname) */ rv = NEWSV(10002, 0); - SEEN(rv, cname); /* Will return if rv is null */ - sv = retrieve(cxt, 0); /* Retrieve */ + SEEN(rv, cname, 0); /* Will return if rv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ @@ -3941,20 +4567,34 @@ static SV *retrieve_overloaded(stcxt_t *cxt, char *cname) * WARNING: breaks RV encapsulation. */ - sv_upgrade(rv, SVt_RV); - SvRV(rv) = sv; /* $rv = \$sv */ + SvUPGRADE(rv, SVt_RV); + SvRV_set(rv, sv); /* $rv = \$sv */ SvROK_on(rv); /* * Restore overloading magic. */ - stash = (HV *) SvSTASH (sv); - if (!stash || !Gv_AMG(stash)) - CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)", + stash = SvTYPE(sv) ? (HV *) SvSTASH (sv) : 0; + if (!stash) { + CROAK(("Cannot restore overloading on %s(0x%"UVxf + ") (package )", sv_reftype(sv, FALSE), - PTR2UV(sv), - stash ? HvNAME(stash) : "")); + 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); @@ -3964,12 +4604,35 @@ static SV *retrieve_overloaded(stcxt_t *cxt, char *cname) } /* + * 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)", 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(stcxt_t *cxt, char *cname) +static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname) { SV *tv; SV *sv; @@ -3977,14 +4640,14 @@ static SV *retrieve_tied_array(stcxt_t *cxt, char *cname) TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv, cname); /* Will return if tv is null */ - sv = retrieve(cxt, 0); /* Retrieve */ + SEEN(tv, cname, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ sv_upgrade(tv, SVt_PVAV); AvREAL_off((AV *)tv); - sv_magic(tv, sv, 'P', Nullch, 0); + 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))); @@ -3998,7 +4661,7 @@ static SV *retrieve_tied_array(stcxt_t *cxt, char *cname) * Retrieve tied hash * Layout is SX_TIED_HASH , with SX_TIED_HASH already read. */ -static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname) +static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname) { SV *tv; SV *sv; @@ -4006,13 +4669,13 @@ static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname) TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv, cname); /* Will return if tv is null */ - sv = retrieve(cxt, 0); /* Retrieve */ + SEEN(tv, cname, 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', Nullch, 0); + 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))); @@ -4026,22 +4689,30 @@ static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname) * Retrieve tied scalar * Layout is SX_TIED_SCALAR , with SX_TIED_SCALAR already read. */ -static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname) +static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname) { SV *tv; - SV *sv; + SV *sv, *obj = NULL; TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv, cname); /* Will return if rv is null */ - sv = retrieve(cxt, 0); /* Retrieve */ - if (!sv) + SEEN(tv, cname, 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, sv, 'q', Nullch, 0); - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ + 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))); @@ -4054,7 +4725,7 @@ static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname) * Retrieve reference to value in a tied hash. * Layout is SX_TIED_KEY , with SX_TIED_KEY already read. */ -static SV *retrieve_tied_key(stcxt_t *cxt, char *cname) +static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname) { SV *tv; SV *sv; @@ -4063,12 +4734,12 @@ static SV *retrieve_tied_key(stcxt_t *cxt, char *cname) TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv, cname); /* Will return if tv is null */ - sv = retrieve(cxt, 0); /* Retrieve */ + SEEN(tv, cname, 0); /* Will return if tv is null */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ - key = retrieve(cxt, 0); /* Retrieve */ + key = retrieve(aTHX_ cxt, 0); /* Retrieve */ if (!key) return (SV *) 0; /* Failed */ @@ -4086,7 +4757,7 @@ static SV *retrieve_tied_key(stcxt_t *cxt, char *cname) * Retrieve reference to value in a tied array. * Layout is SX_TIED_IDX , with SX_TIED_IDX already read. */ -static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname) +static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname) { SV *tv; SV *sv; @@ -4095,15 +4766,15 @@ static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname) TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv, cname); /* Will return if tv is null */ - sv = retrieve(cxt, 0); /* Retrieve */ + SEEN(tv, cname, 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', Nullch, idx); + sv_magic(tv, sv, 'p', (char *)NULL, idx); SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ return tv; @@ -4119,20 +4790,25 @@ static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname) * The scalar is "long" in that is larger than LG_SCALAR so it * was not stored on a single byte. */ -static SV *retrieve_lscalar(stcxt_t *cxt, char *cname) +static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname) { I32 len; SV *sv; RLEN(len); - TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, len)); + TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, (IV) len)); /* * Allocate an empty scalar of the suitable length. */ sv = NEWSV(10002, len); - SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ + + if (len == 0) { + sv_setpvn(sv, "", 0); + return sv; + } /* * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. @@ -4150,7 +4826,7 @@ static SV *retrieve_lscalar(stcxt_t *cxt, char *cname) if (cxt->s_tainted) /* Is input source tainted? */ SvTAINT(sv); /* External data cannot be trusted */ - TRACEME(("large scalar len %"IVdf" '%s'", len, SvPVX(sv))); + TRACEME(("large scalar len %"IVdf" '%s'", (IV) len, SvPVX(sv))); TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv))); return sv; @@ -4165,7 +4841,7 @@ static SV *retrieve_lscalar(stcxt_t *cxt, char *cname) * The scalar is "short" so is single byte. If it is 0, there * is no section. */ -static SV *retrieve_scalar(stcxt_t *cxt, char *cname) +static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname) { int len; SV *sv; @@ -4178,7 +4854,7 @@ static SV *retrieve_scalar(stcxt_t *cxt, char *cname) */ sv = NEWSV(10002, len); - SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ /* * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. @@ -4224,13 +4900,13 @@ static SV *retrieve_scalar(stcxt_t *cxt, char *cname) * Like retrieve_scalar(), but tag result as utf8. * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. */ -static SV *retrieve_utf8str(stcxt_t *cxt, char *cname) +static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname) { SV *sv; TRACEME(("retrieve_utf8str")); - sv = retrieve_scalar(cxt, cname); + sv = retrieve_scalar(aTHX_ cxt, cname); if (sv) { #ifdef HAS_UTF8_SCALARS SvUTF8_on(sv); @@ -4253,13 +4929,13 @@ static SV *retrieve_utf8str(stcxt_t *cxt, char *cname) * Like retrieve_lscalar(), but tag result as utf8. * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. */ -static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname) +static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname) { SV *sv; TRACEME(("retrieve_lutf8str")); - sv = retrieve_lscalar(cxt, cname); + sv = retrieve_lscalar(aTHX_ cxt, cname); if (sv) { #ifdef HAS_UTF8_SCALARS SvUTF8_on(sv); @@ -4281,7 +4957,7 @@ static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname) * Retrieve defined integer. * Layout is SX_INTEGER , whith SX_INTEGER already read. */ -static SV *retrieve_integer(stcxt_t *cxt, char *cname) +static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname) { SV *sv; IV iv; @@ -4290,7 +4966,7 @@ static SV *retrieve_integer(stcxt_t *cxt, char *cname) READ(&iv, sizeof(iv)); sv = newSViv(iv); - SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ TRACEME(("integer %"IVdf, iv)); TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv))); @@ -4304,7 +4980,7 @@ static SV *retrieve_integer(stcxt_t *cxt, char *cname) * Retrieve defined integer in network order. * Layout is SX_NETINT , whith SX_NETINT already read. */ -static SV *retrieve_netint(stcxt_t *cxt, char *cname) +static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname) { SV *sv; I32 iv; @@ -4319,7 +4995,7 @@ static SV *retrieve_netint(stcxt_t *cxt, char *cname) sv = newSViv(iv); TRACEME(("network integer (as-is) %d", iv)); #endif - SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv))); @@ -4332,7 +5008,7 @@ static SV *retrieve_netint(stcxt_t *cxt, char *cname) * Retrieve defined double. * Layout is SX_DOUBLE , whith SX_DOUBLE already read. */ -static SV *retrieve_double(stcxt_t *cxt, char *cname) +static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname) { SV *sv; NV nv; @@ -4341,7 +5017,7 @@ static SV *retrieve_double(stcxt_t *cxt, char *cname) READ(&nv, sizeof(nv)); sv = newSVnv(nv); - SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ TRACEME(("double %"NVff, nv)); TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv))); @@ -4355,7 +5031,7 @@ static SV *retrieve_double(stcxt_t *cxt, char *cname) * Retrieve defined byte (small integer within the [-128, +127] range). * Layout is SX_BYTE , whith SX_BYTE already read. */ -static SV *retrieve_byte(stcxt_t *cxt, char *cname) +static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname) { SV *sv; int siv; @@ -4367,7 +5043,7 @@ static SV *retrieve_byte(stcxt_t *cxt, char *cname) TRACEME(("small integer read as %d", (unsigned char) siv)); tmp = (unsigned char) siv - 128; sv = newSViv(tmp); - SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */ TRACEME(("byte %d", tmp)); TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv))); @@ -4380,14 +5056,14 @@ static SV *retrieve_byte(stcxt_t *cxt, char *cname) * * Return the undefined value. */ -static SV *retrieve_undef(stcxt_t *cxt, char *cname) +static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname) { SV* sv; TRACEME(("retrieve_undef")); sv = newSV(0); - SEEN(sv, cname); + SEEN(sv, cname, 0); return sv; } @@ -4397,13 +5073,19 @@ static SV *retrieve_undef(stcxt_t *cxt, char *cname) * * Return the immortal undefined value. */ -static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname) +static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname) { SV *sv = &PL_sv_undef; TRACEME(("retrieve_sv_undef")); - SEEN(sv, cname); + /* Special case PL_sv_undef, as av_fetch uses it internally to mark + deleted elements, and will return NULL (fetch failed) whenever it + is fetched. */ + if (cxt->where_is_undef == -1) { + cxt->where_is_undef = cxt->tagnum; + } + SEEN(sv, cname, 1); return sv; } @@ -4412,13 +5094,13 @@ static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname) * * Return the immortal yes value. */ -static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname) +static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname) { SV *sv = &PL_sv_yes; TRACEME(("retrieve_sv_yes")); - SEEN(sv, cname); + SEEN(sv, cname, 1); return sv; } @@ -4427,13 +5109,13 @@ static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname) * * Return the immortal no value. */ -static SV *retrieve_sv_no(stcxt_t *cxt, char *cname) +static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname) { SV *sv = &PL_sv_no; TRACEME(("retrieve_sv_no")); - SEEN(sv, cname); + SEEN(sv, cname, 1); return sv; } @@ -4446,7 +5128,7 @@ static SV *retrieve_sv_no(stcxt_t *cxt, char *cname) * * When we come here, SX_ARRAY has been read already. */ -static SV *retrieve_array(stcxt_t *cxt, char *cname) +static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) { I32 len; I32 i; @@ -4462,7 +5144,7 @@ static SV *retrieve_array(stcxt_t *cxt, char *cname) RLEN(len); TRACEME(("size = %d", len)); av = newAV(); - SEEN(av, cname); /* Will return if array not allocated nicely */ + SEEN(av, cname, 0); /* Will return if array not allocated nicely */ if (len) av_extend(av, len); else @@ -4474,7 +5156,7 @@ static SV *retrieve_array(stcxt_t *cxt, char *cname) for (i = 0; i < len; i++) { TRACEME(("(#%d) item", i)); - sv = retrieve(cxt, 0); /* Retrieve item */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ if (!sv) return (SV *) 0; if (av_store(av, i, sv) == 0) @@ -4497,7 +5179,7 @@ static SV *retrieve_array(stcxt_t *cxt, char *cname) * * When we come here, SX_HASH has been read already. */ -static SV *retrieve_hash(stcxt_t *cxt, char *cname) +static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname) { I32 len; I32 size; @@ -4514,7 +5196,7 @@ static SV *retrieve_hash(stcxt_t *cxt, char *cname) RLEN(len); TRACEME(("size = %d", len)); hv = newHV(); - SEEN(hv, cname); /* Will return if table not allocated properly */ + SEEN(hv, cname, 0); /* Will return if table not allocated properly */ if (len == 0) return (SV *) hv; /* No data follow if table empty */ hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */ @@ -4529,7 +5211,7 @@ static SV *retrieve_hash(stcxt_t *cxt, char *cname) */ TRACEME(("(#%d) value", i)); - sv = retrieve(cxt, 0); + sv = retrieve(aTHX_ cxt, 0); if (!sv) return (SV *) 0; @@ -4571,8 +5253,9 @@ static SV *retrieve_hash(stcxt_t *cxt, char *cname) * * When we come here, SX_HASH has been read already. */ -static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) +static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) { + dVAR; I32 len; I32 size; I32 i; @@ -4600,7 +5283,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) RLEN(len); TRACEME(("size = %d, flags = %d", len, hash_flags)); hv = newHV(); - SEEN(hv, cname); /* Will return if table not allocated properly */ + SEEN(hv, cname, 0); /* Will return if table not allocated properly */ if (len == 0) return (SV *) hv; /* No data follow if table empty */ hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */ @@ -4617,7 +5300,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) */ TRACEME(("(#%d) value", i)); - sv = retrieve(cxt, 0); + sv = retrieve(aTHX_ cxt, 0); if (!sv) return (SV *) 0; @@ -4634,7 +5317,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) */ SV *keysv; TRACEME(("(#%d) keysv, flags=%d", i, flags)); - keysv = retrieve(cxt, 0); + keysv = retrieve(aTHX_ cxt, 0); if (!keysv) return (SV *) 0; @@ -4650,7 +5333,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) if (flags & SHV_K_PLACEHOLDER) { SvREFCNT_dec (sv); - sv = &PL_sv_undef; + sv = &PL_sv_placeholder; store_flags |= HVhek_PLACEHOLD; } if (flags & SHV_K_UTF8) { @@ -4683,7 +5366,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) */ #ifdef HAS_RESTRICTED_HASHES - if (hv_store_flags(hv, kbuf, size, sv, 0, flags) == 0) + if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0) return (SV *) 0; #else if (!(store_flags & HVhek_PLACEHOLD)) @@ -4703,6 +5386,122 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) } /* + * retrieve_code + * + * Return a code reference. + */ +static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname) +{ +#if PERL_VERSION < 6 + CROAK(("retrieve_code does not work with perl 5.005 or less\n")); +#else + dSP; + int type, count, tagnum; + SV *cv; + SV *sv, *text, *sub; + + TRACEME(("retrieve_code (#%d)", cxt->tagnum)); + + /* + * Insert dummy SV in the aseen array so that we don't screw + * up the tag numbers. We would just make the internal + * scalar an untagged item in the stream, but + * retrieve_scalar() calls SEEN(). So we just increase the + * tag number. + */ + tagnum = cxt->tagnum; + sv = newSViv(0); + SEEN(sv, cname, 0); + + /* + * Retrieve the source of the code reference + * as a small or large scalar + */ + + GETMARK(type); + switch (type) { + case SX_SCALAR: + text = retrieve_scalar(aTHX_ cxt, cname); + break; + case SX_LSCALAR: + text = retrieve_lscalar(aTHX_ cxt, cname); + break; + default: + CROAK(("Unexpected type %d in retrieve_code\n", type)); + } + + /* + * prepend "sub " to the source + */ + + sub = newSVpvn("sub ", 4); + sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */ + SvREFCNT_dec(text); + + /* + * evaluate the source to a code reference and use the CV value + */ + + if (cxt->eval == NULL) { + cxt->eval = perl_get_sv("Storable::Eval", TRUE); + SvREFCNT_inc(cxt->eval); + } + if (!SvTRUE(cxt->eval)) { + if ( + cxt->forgive_me == 0 || + (cxt->forgive_me < 0 && !(cxt->forgive_me = + SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0)) + ) { + CROAK(("Can't eval, please set $Storable::Eval to a true value")); + } else { + sv = newSVsv(sub); + /* fix up the dummy entry... */ + av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); + return sv; + } + } + + ENTER; + SAVETMPS; + + if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) { + SV* errsv = get_sv("@", TRUE); + sv_setpvn(errsv, "", 0); /* clear $@ */ + PUSHMARK(sp); + XPUSHs(sv_2mortal(newSVsv(sub))); + PUTBACK; + count = call_sv(cxt->eval, G_SCALAR); + SPAGAIN; + if (count != 1) + CROAK(("Unexpected return value from $Storable::Eval callback\n")); + cv = POPs; + if (SvTRUE(errsv)) { + CROAK(("code %s caused an error: %s", + SvPV_nolen(sub), SvPV_nolen(errsv))); + } + PUTBACK; + } else { + cv = eval_pv(SvPV_nolen(sub), TRUE); + } + if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) { + sv = SvRV(cv); + } else { + CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub))); + } + + SvREFCNT_inc(sv); /* XXX seems to be necessary */ + SvREFCNT_dec(sub); + + FREETMPS; + LEAVE; + /* fix up the dummy entry... */ + av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); + + return sv; +#endif +} + +/* * old_retrieve_array * * Retrieve a whole array in pre-0.6 binary format. @@ -4712,7 +5511,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) * * When we come here, SX_ARRAY has been read already. */ -static SV *old_retrieve_array(stcxt_t *cxt, char *cname) +static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) { I32 len; I32 i; @@ -4729,7 +5528,7 @@ static SV *old_retrieve_array(stcxt_t *cxt, char *cname) RLEN(len); TRACEME(("size = %d", len)); av = newAV(); - SEEN(av, 0); /* Will return if array not allocated nicely */ + SEEN(av, 0, 0); /* Will return if array not allocated nicely */ if (len) av_extend(av, len); else @@ -4746,9 +5545,9 @@ static SV *old_retrieve_array(stcxt_t *cxt, char *cname) continue; /* av_extend() already filled us with undef */ } if (c != SX_ITEM) - (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */ + (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ TRACEME(("(#%d) item", i)); - sv = retrieve(cxt, 0); /* Retrieve item */ + sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ if (!sv) return (SV *) 0; if (av_store(av, i, sv) == 0) @@ -4772,7 +5571,7 @@ static SV *old_retrieve_array(stcxt_t *cxt, char *cname) * * When we come here, SX_HASH has been read already. */ -static SV *old_retrieve_hash(stcxt_t *cxt, char *cname) +static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname) { I32 len; I32 size; @@ -4780,7 +5579,7 @@ static SV *old_retrieve_hash(stcxt_t *cxt, char *cname) HV *hv; SV *sv = (SV *) 0; int c; - static SV *sv_h_undef = (SV *) 0; /* hv_store() bug */ + SV *sv_h_undef = (SV *) 0; /* hv_store() bug */ TRACEME(("old_retrieve_hash (#%d)", cxt->tagnum)); @@ -4791,7 +5590,7 @@ static SV *old_retrieve_hash(stcxt_t *cxt, char *cname) RLEN(len); TRACEME(("size = %d", len)); hv = newHV(); - SEEN(hv, 0); /* Will return if table not allocated properly */ + SEEN(hv, 0, 0); /* Will return if table not allocated properly */ if (len == 0) return (SV *) hv; /* No data follow if table empty */ hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */ @@ -4818,11 +5617,11 @@ static SV *old_retrieve_hash(stcxt_t *cxt, char *cname) sv = SvREFCNT_inc(sv_h_undef); } else if (c == SX_VALUE) { TRACEME(("(#%d) value", i)); - sv = retrieve(cxt, 0); + sv = retrieve(aTHX_ cxt, 0); if (!sv) return (SV *) 0; } else - (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */ + (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ /* * Get key. @@ -4833,7 +5632,7 @@ static SV *old_retrieve_hash(stcxt_t *cxt, char *cname) GETMARK(c); if (c != SX_KEY) - (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */ + (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ RLEN(size); /* Get key size */ KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ if (size) @@ -4869,142 +5668,184 @@ static SV *old_retrieve_hash(stcxt_t *cxt, char *cname) * Note that there's no byte ordering info emitted when network order was * used at store time. */ -static SV *magic_check(stcxt_t *cxt) +static SV *magic_check(pTHX_ stcxt_t *cxt) { - char buf[256]; - char byteorder[256]; - int c; - int use_network_order; - int version_major; - int version_minor = 0; + /* 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")); - TRACEME(("magic_check")); + /* + * The "magic number" is only for files, not when freezing in memory. + */ - /* - * 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; - if (cxt->fio) { - STRLEN len = sizeof(magicstr) - 1; - STRLEN old_len; + READ(buf, (SSize_t)(len)); /* Not null-terminated */ - READ(buf, (SSize_t)len); /* Not null-terminated */ - buf[len] = '\0'; /* Is now */ + /* Point at the byte after the byte we read. */ + current = buf + --len; /* Do the -- outside of macros. */ - if (0 == strcmp(buf, magicstr)) - goto magic_ok; + if (memNE(buf, magicstr, len)) { + /* + * Try to read more bytes to check for the old magic number, which + * was longer. + */ - /* - * 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(&buf[len], (SSize_t)(old_len - len)); - buf[old_len] = '\0'; /* Is now null-terminated */ + 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); - if (strcmp(buf, old_magicstr)) - CROAK(("File is not a perl storable")); - } + TRACEME(("magic_check: netorder = 0x%x", use_network_order)); -magic_ok: - /* - * 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(). - */ - GETMARK(use_network_order); - version_major = use_network_order >> 1; - cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve; + /* + * Starting with 0.7 (binary major 2), a full byte is dedicated to the + * minor version of the protocol. See magic_write(). + */ - TRACEME(("magic_check: netorder = 0x%x", use_network_order)); + if (version_major > 1) + GETMARK(version_minor); + cxt->ver_major = version_major; + cxt->ver_minor = version_minor; - /* - * Starting with 0.7 (binary major 2), a full byte is dedicated to the - * minor version of the protocol. See magic_write(). - */ + TRACEME(("binary image version is %d.%d", version_major, version_minor)); - if (version_major > 1) - GETMARK(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. + */ - cxt->ver_major = version_major; - cxt->ver_minor = version_minor; + if ( + version_major > STORABLE_BIN_MAJOR || + (version_major == STORABLE_BIN_MAJOR && + version_minor > STORABLE_BIN_MINOR) + ) { + int croak_now = 1; + TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR, + STORABLE_BIN_MINOR)); + + if (version_major == STORABLE_BIN_MAJOR) { + TRACEME(("cxt->accept_future_minor is %d", + cxt->accept_future_minor)); + if (cxt->accept_future_minor < 0) + cxt->accept_future_minor + = (SvTRUE(perl_get_sv("Storable::accept_future_minor", + TRUE)) + ? 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)); + } + } - TRACEME(("binary image version is %d.%d", version_major, version_minor)); + /* + * If they stored using network order, there's no byte ordering + * information to check. + */ - /* - * 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 ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */ + return &PL_sv_undef; /* No byte ordering info */ - if ( - version_major > STORABLE_BIN_MAJOR || - (version_major == STORABLE_BIN_MAJOR && - version_minor > STORABLE_BIN_MINOR) - ) { - int croak_now = 1; - TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR, - STORABLE_BIN_MINOR)); - - if (version_major == STORABLE_BIN_MAJOR) { - TRACEME(("cxt->accept_future_minor is %d", - cxt->accept_future_minor)); - if (cxt->accept_future_minor < 0) - cxt->accept_future_minor - = (SvTRUE(perl_get_sv("Storable::accept_future_minor", - TRUE)) - ? 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)); - } - } + /* In C truth is 1, falsehood is 0. Very convienient. */ + use_NV_size = version_major >= 2 && version_minor >= 2; - /* - * If they stored using network order, there's no byte ordering - * information to check. - */ + if (version_major >= 0) { + GETMARK(c); + } + else { + c = use_network_order; + } + length = c + 3 + use_NV_size; + READ(buf, length); /* Not null-terminated */ + + TRACEME(("byte order '%.*s' %d", c, buf, c)); + +#ifdef USE_56_INTERWORK_KLUDGE + /* No point in caching this in the context as we only need it once per + retrieve, and we need to recheck it each read. */ + if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) { + 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")); + } - if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */ - return &PL_sv_undef; /* No byte ordering info */ + current = buf + c; + + /* sizeof(int) */ + if ((int) *current++ != sizeof(int)) + CROAK(("Integer size is not compatible")); - sprintf(byteorder, "%lx", (unsigned long) BYTEORDER); - GETMARK(c); - READ(buf, c); /* Not null-terminated */ - buf[c] = '\0'; /* Is now */ + /* sizeof(long) */ + if ((int) *current++ != sizeof(long)) + CROAK(("Long integer size is not compatible")); - TRACEME(("byte order '%s'", buf)); + /* sizeof(char *) */ + if ((int) *current != sizeof(char *)) + CROAK(("Pointer size is not compatible")); - if (strcmp(buf, byteorder)) - CROAK(("Byte order is not compatible")); - - GETMARK(c); /* sizeof(int) */ - if ((int) c != sizeof(int)) - CROAK(("Integer size is not compatible")); - - GETMARK(c); /* sizeof(long) */ - if ((int) c != sizeof(long)) - CROAK(("Long integer size is not compatible")); - - GETMARK(c); /* sizeof(char *) */ - if ((int) c != sizeof(char *)) - CROAK(("Pointer integer size is not compatible")); - - if (version_major >= 2 && version_minor >= 2) { - GETMARK(c); /* sizeof(NV) */ - if ((int) c != sizeof(NV)) - CROAK(("Double 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 */ + return &PL_sv_undef; /* OK */ } /* @@ -5014,7 +5855,7 @@ magic_ok: * root SV (which may be an AV or an HV for what we care). * Returns null if there is a problem. */ -static SV *retrieve(stcxt_t *cxt, char *cname) +static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname) { int type; SV **svh; @@ -5123,7 +5964,7 @@ first_time: /* Will disappear when support for old format is dropped */ * Okay, first time through for this one. */ - sv = RETRIEVE(cxt, type)(cxt, cname); + sv = RETRIEVE(cxt, type)(aTHX_ cxt, cname); if (!sv) return (SV *) 0; /* Failed */ @@ -5174,6 +6015,7 @@ first_time: /* Will disappear when support for old format is dropped */ * Common routine for pretrieve and mretrieve. */ static SV *do_retrieve( + pTHX_ PerlIO *f, SV *in, int optype) @@ -5204,7 +6046,7 @@ static SV *do_retrieve( */ if (cxt->s_dirty) - clean_context(cxt); + clean_context(aTHX_ cxt); /* * Now that STORABLE_xxx hooks exist, it is possible that they try to @@ -5212,7 +6054,7 @@ static SV *do_retrieve( */ if (cxt->entry) - cxt = allocate_context(cxt); + cxt = allocate_context(aTHX_ cxt); cxt->entry++; @@ -5229,8 +6071,46 @@ static SV *do_retrieve( KBUFINIT(); /* Allocate hash key reading pool once */ - if (!f && in) + 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. @@ -5242,7 +6122,7 @@ static SV *do_retrieve( cxt->fio = f; /* Where I/O are performed */ - if (!magic_check(cxt)) + if (!magic_check(aTHX_ cxt)) CROAK(("Magic number checking on storable %s failed", cxt->fio ? "file" : "string")); @@ -5261,11 +6141,11 @@ static SV *do_retrieve( is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted); TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted")); - init_retrieve_context(cxt, optype, is_tainted); + init_retrieve_context(aTHX_ cxt, optype, is_tainted); - ASSERT(is_retrieving(), ("within retrieve operation")); + ASSERT(is_retrieving(aTHX), ("within retrieve operation")); - sv = retrieve(cxt, 0); /* Recursively retrieve object, get root SV */ + sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */ /* * Final cleanup. @@ -5280,9 +6160,9 @@ static SV *do_retrieve( * The "root" context is never freed. */ - clean_retrieve_context(cxt); + clean_retrieve_context(aTHX_ cxt); if (cxt->prev) /* This context was stacked */ - free_context(cxt); /* It was not the "root" context */ + free_context(aTHX_ cxt); /* It was not the "root" context */ /* * Prepare returned value. @@ -5290,7 +6170,22 @@ static SV *do_retrieve( if (!sv) { TRACEME(("retrieve ERROR")); +#if (PATCHLEVEL <= 4) + /* perl 5.00405 seems to screw up at this point with an + 'attempt to modify a read only value' error reported in the + eval { $self = pretrieve(*FILE) } in _retrieve. + I can't see what the cause of this error is, but I suspect a + bug in 5.004, as it seems to be capable of issuing spurious + errors or core dumping with matches on $@. I'm not going to + spend time on what could be a fruitless search for the cause, + so here's a bodge. If you're running 5.004 and don't like + this inefficiency, either upgrade to a newer perl, or you are + welcome to find the problem and send in a patch. + */ + return newSV(0); +#else return &PL_sv_undef; /* Something went wrong, return undef */ +#endif } TRACEME(("retrieve got %s(0x%"UVxf")", @@ -5308,7 +6203,7 @@ static SV *do_retrieve( if (pre_06_fmt) { /* Was not handling overloading by then */ SV *rv; TRACEME(("fixing for old formats -- pre 0.6")); - if (sv_type(sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) { + if (sv_type(aTHX_ sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) { TRACEME(("ended do_retrieve() with an object -- pre 0.6")); return sv; } @@ -5352,10 +6247,10 @@ static SV *do_retrieve( * * Retrieve data held in file and return the root object, undef on error. */ -SV *pretrieve(PerlIO *f) +static SV *pretrieve(pTHX_ PerlIO *f) { TRACEME(("pretrieve")); - return do_retrieve(f, Nullsv, 0); + return do_retrieve(aTHX_ f, Nullsv, 0); } /* @@ -5363,10 +6258,10 @@ SV *pretrieve(PerlIO *f) * * Retrieve data held in scalar and return the root object, undef on error. */ -SV *mretrieve(SV *sv) +static SV *mretrieve(pTHX_ SV *sv) { TRACEME(("mretrieve")); - return do_retrieve((PerlIO*) 0, sv, 0); + return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0); } /*** @@ -5382,7 +6277,7 @@ SV *mretrieve(SV *sv) * there. Not that efficient, but it should be faster than doing it from * pure perl anyway. */ -SV *dclone(SV *sv) +static SV *dclone(pTHX_ SV *sv) { dSTCXT; int size; @@ -5397,14 +6292,26 @@ SV *dclone(SV *sv) */ if (cxt->s_dirty) - clean_context(cxt); + clean_context(aTHX_ cxt); + + /* + * Tied elements seem to need special handling. + */ + + if ((SvTYPE(sv) == SVt_PVLV +#if PERL_VERSION < 8 + || SvTYPE(sv) == SVt_PVMG +#endif + ) && SvRMAGICAL(sv) && mg_find(sv, 'p')) { + mg_get(sv); + } /* * do_store() optimizes for dclone by not freeing its context, should * we need to allocate one because we're deep cloning from a hook. */ - if (!do_store((PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0)) + if (!do_store(aTHX_ (PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0)) return &PL_sv_undef; /* Error during store */ /* @@ -5435,7 +6342,7 @@ SV *dclone(SV *sv) */ cxt->s_tainted = SvTAINTED(sv); - out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE); + out = do_retrieve(aTHX_ (PerlIO*) 0, Nullsv, ST_CLONE); TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out))); @@ -5482,44 +6389,103 @@ MODULE = Storable PACKAGE = Storable PROTOTYPES: ENABLE BOOT: - init_perinterp(); +{ + HV *stash = gv_stashpvn("Storable", 8, GV_ADD); + newCONSTSUB(stash, "BIN_MAJOR", newSViv(STORABLE_BIN_MAJOR)); + newCONSTSUB(stash, "BIN_MINOR", newSViv(STORABLE_BIN_MINOR)); + newCONSTSUB(stash, "BIN_WRITE_MINOR", newSViv(STORABLE_BIN_WRITE_MINOR)); + + init_perinterp(aTHX); + gv_fetchpv("Storable::drop_utf8", GV_ADDMULTI, SVt_PV); +#ifdef DEBUGME + /* Only disable the used only once warning if we are in debugging mode. */ + gv_fetchpv("Storable::DEBUGME", GV_ADDMULTI, SVt_PV); +#endif +#ifdef USE_56_INTERWORK_KLUDGE + gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV); +#endif +} + +void +init_perinterp() + CODE: + init_perinterp(aTHX); int pstore(f,obj) OutputStream f SV * obj + CODE: + RETVAL = pstore(aTHX_ f, obj); + OUTPUT: + RETVAL int net_pstore(f,obj) OutputStream f SV * obj + CODE: + RETVAL = net_pstore(aTHX_ f, obj); + OUTPUT: + RETVAL SV * mstore(obj) SV * obj + CODE: + RETVAL = mstore(aTHX_ obj); + OUTPUT: + RETVAL SV * net_mstore(obj) SV * obj + CODE: + RETVAL = net_mstore(aTHX_ obj); + OUTPUT: + RETVAL SV * pretrieve(f) InputStream f + CODE: + RETVAL = pretrieve(aTHX_ f); + OUTPUT: + RETVAL SV * mretrieve(sv) SV * sv + CODE: + RETVAL = mretrieve(aTHX_ sv); + OUTPUT: + RETVAL SV * dclone(sv) SV * sv + CODE: + RETVAL = dclone(aTHX_ sv); + OUTPUT: + RETVAL int last_op_in_netorder() + CODE: + RETVAL = last_op_in_netorder(aTHX); + OUTPUT: + RETVAL int is_storing() + CODE: + RETVAL = is_storing(aTHX); + OUTPUT: + RETVAL int is_retrieving() - + CODE: + RETVAL = is_retrieving(aTHX); + OUTPUT: + RETVAL