X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FStorable%2FStorable.xs;h=24de05f88d24be8cf321a33f33c6a66b8c5ff543;hb=5e137bc214f9c21ed33df8110b67005fb915c4e7;hp=b7ddc739e640806551d752bcd000ac37e7448857;hpb=aa6930702d30b377634933794b8700d63528659d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index b7ddc73..24de05f 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -8,22 +8,26 @@ * */ +#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 @@ -85,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 @@ -150,7 +204,9 @@ typedef double NV; /* Older perls lack the NV type */ #define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */ #define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */ #define SX_CODE C(26) /* Code references as perl source code */ -#define SX_ERROR C(27) /* Error */ +#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. @@ -258,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 @@ -270,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 */ @@ -308,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; @@ -317,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; \ @@ -464,7 +538,7 @@ static stcxt_t *Context_ptr = NULL; if (!mbase) { \ TRACEME(("** allocating mbase of %d bytes", MGROW)); \ New(10003, mbase, MGROW, char); \ - msiz = MGROW; \ + msiz = (STRLEN)MGROW; \ } \ mptr = mbase; \ if (x) \ @@ -585,6 +659,17 @@ static stcxt_t *Context_ptr = NULL; } \ } 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) \ @@ -748,7 +833,7 @@ static const char magicstr[] = "pst0"; /* Used as a magic number */ #if BYTEORDER == 0x4321 #define BYTEORDER_BYTES '4','3','2','1' #else -#error Unknown byteoder. Please append your byteorder to Storable.xs +#error Unknown byteorder. Please append your byteorder to Storable.xs #endif #endif #endif @@ -760,27 +845,32 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #endif #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ -#define STORABLE_BIN_MINOR 6 /* 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 6 -#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) \ @@ -844,12 +934,12 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #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 /* @@ -910,6 +1000,16 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; } \ } STMT_END +#define SAFEPVREAD(x,y,z) \ + STMT_START { \ + if (!cxt->fio) \ + MBUF_SAFEPVREAD(x,y,z); \ + else if (PerlIO_read(cxt->fio, x, y) != y) { \ + Safefree(z); \ + return (SV *) 0; \ + } \ + } STMT_END + /* * This macro is used at retrieve time, to remember where object 'y', bearing a * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker, @@ -927,12 +1027,14 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; * 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)); \ @@ -948,39 +1050,71 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; 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_code(stcxt_t *cxt, CV *cv); -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 */ - (int (*)(stcxt_t *cxt, SV *sv)) store_code, /* svis_CODE */ - 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]) @@ -989,102 +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_CODE 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 *retrieve_code(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_code, /* SX_CODE */ - 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. @@ -1095,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 */ } /* @@ -1122,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, @@ -1152,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 @@ -1173,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 @@ -1216,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; @@ -1228,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); @@ -1250,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; @@ -1294,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")); @@ -1309,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 @@ -1316,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 */ @@ -1339,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")); @@ -1351,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; @@ -1389,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")); @@ -1401,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); @@ -1417,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; @@ -1441,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); @@ -1466,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; @@ -1478,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; @@ -1493,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; @@ -1513,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 @@ -1528,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)); } /* @@ -1539,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; } @@ -1550,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); } /* @@ -1564,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); } /* @@ -1580,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 @@ -1597,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 */ } /* @@ -1621,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, @@ -1677,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) @@ -1722,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 */ @@ -1765,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); } /* @@ -1799,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; @@ -1954,7 +2138,7 @@ static int store_scalar(stcxt_t *cxt, SV *sv) #else SvIV_please(sv); - if (SvIOK(sv)) { + if (SvIOK_notUV(sv)) { iv = SvIV(sv); goto integer; /* Share code above */ } @@ -2005,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; @@ -2030,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; } @@ -2043,6 +2227,9 @@ static int store_array(stcxt_t *cxt, AV *av) return 0; } + +#if (PATCHLEVEL <= 6) + /* * sortcmp * @@ -2052,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 @@ -2078,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); @@ -2122,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); /* @@ -2161,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. @@ -2184,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; /* @@ -2197,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; @@ -2242,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); @@ -2263,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 @@ -2282,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); @@ -2333,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) @@ -2349,8 +2587,8 @@ 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; } @@ -2363,17 +2601,17 @@ out: * Layout is SX_CODE followed by a scalar containing the perl * source code of the code reference. */ -static int store_code(stcxt_t *cxt, CV *cv) +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(cxt, (SV*)cv); + return store_other(aTHX_ cxt, (SV*)cv); #else dSP; I32 len; - int ret, count, reallen; + int count, reallen; SV *text, *bdeparse; TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv))); @@ -2383,15 +2621,16 @@ static int store_code(stcxt_t *cxt, CV *cv) (cxt->deparse < 0 && !(cxt->deparse = SvTRUE(perl_get_sv("Storable::Deparse", TRUE)) ? 1 : 0)) ) { - return store_other(cxt, (SV*)cv); + return store_other(aTHX_ cxt, (SV*)cv); } /* * Require B::Deparse. At least B::Deparse 0.61 is needed for * blessed code references. */ - /* XXX sv_2mortal seems to be evil here. why? */ + /* 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; @@ -2423,15 +2662,15 @@ static int store_code(stcxt_t *cxt, CV *cv) CROAK(("Unexpected return value from B::Deparse::coderef2text\n")); text = POPs; - len = SvLEN(text); - reallen = strlen(SvPV(text,PL_na)); + len = SvCUR(text); + reallen = strlen(SvPV_nolen(text)); /* * Empty code references or XS functions are deparsed as * "(prototype) ;" or ";". */ - if (len == 0 || *(SvPV(text,PL_na)+reallen-1) == ';') { + 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")); } @@ -2440,14 +2679,15 @@ static int store_code(stcxt_t *cxt, CV *cv) */ PUTMARK(SX_CODE); + cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */ TRACEME(("size = %d", len)); - TRACEME(("code = %s", SvPV(text,PL_na))); + TRACEME(("code = %s", SvPV_nolen(text))); /* * Now store the source code. */ - STORE_SCALAR(SvPV(text,PL_na), len); + STORE_SCALAR(SvPV_nolen(text), len); FREETMPS; LEAVE; @@ -2466,9 +2706,10 @@ static int store_code(stcxt_t *cxt, CV *cv) * 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'; @@ -2514,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)")); @@ -2534,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; @@ -2553,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; @@ -2567,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)); @@ -2626,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, @@ -2633,7 +2877,7 @@ static int store_hook( SV *hook) { I32 len; - char *class; + char *classname; STRLEN len2; SV *ref; AV *av; @@ -2650,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. @@ -2701,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: @@ -2717,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; @@ -2741,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); } /* @@ -2759,6 +3003,16 @@ 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 @@ -2774,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))); @@ -2814,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'. * @@ -2850,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))); } /* @@ -2864,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)); } /* @@ -2924,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 */ } /* */ @@ -2991,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; } @@ -3023,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, @@ -3030,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 @@ -3061,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; @@ -3073,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; @@ -3083,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); } /* @@ -3103,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")); @@ -3150,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 @@ -3162,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: /* @@ -3180,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; @@ -3194,6 +3482,9 @@ static int sv_type(SV *sv) return svis_HASH; case SVt_PVCV: return svis_CODE; +#if PERL_VERSION > 8 + /* case SVt_BIND: */ +#endif default: break; } @@ -3210,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))); @@ -3231,9 +3526,49 @@ static int store(stcxt_t *cxt, SV *sv) * -- 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))); @@ -3254,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), @@ -3292,7 +3632,7 @@ 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) { /* * Starting with 0.6, the "use_network_order" byte flag is also used to @@ -3366,7 +3706,7 @@ static int magic_write(stcxt_t *cxt) length -= sizeof (magicstr) - 1; } - WRITE(header, length); + WRITE( (unsigned char*) header, length); if (!cxt->netorder) { TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)", @@ -3389,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, @@ -3412,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 @@ -3420,7 +3761,7 @@ static int do_store( */ if (cxt->entry) - cxt = allocate_context(cxt); + cxt = allocate_context(aTHX_ cxt); cxt->entry++; @@ -3430,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. */ @@ -3449,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, @@ -3472,7 +3813,7 @@ static int do_store( */ if (!cxt->fio && res) - *res = mbuf2sv(); + *res = mbuf2sv(aTHX); /* * Final cleanup. @@ -3490,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)); @@ -3505,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); } @@ -3518,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); } /*** @@ -3533,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; @@ -3546,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; @@ -3564,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; @@ -3586,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 && @@ -3611,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; @@ -3633,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; } @@ -3652,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)); @@ -3673,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; } @@ -3718,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; @@ -3731,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'; @@ -3784,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. @@ -3806,7 +4152,7 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) 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); @@ -3833,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 { /* @@ -3844,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); @@ -3852,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. @@ -3931,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); } @@ -3943,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)); } /* @@ -4005,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), (IV) 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); /* @@ -4018,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 @@ -4031,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))); @@ -4074,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; @@ -4086,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; @@ -4103,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 */ @@ -4125,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))); @@ -4135,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; @@ -4153,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 */ @@ -4162,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); @@ -4185,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; @@ -4198,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))); @@ -4219,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; @@ -4227,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))); @@ -4247,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))); @@ -4275,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; @@ -4284,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 */ @@ -4307,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; @@ -4316,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; @@ -4340,7 +4790,7 @@ 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; @@ -4353,7 +4803,12 @@ static SV *retrieve_lscalar(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" */ + + if (len == 0) { + sv_setpvn(sv, "", 0); + return sv; + } /* * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. @@ -4386,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; @@ -4399,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. @@ -4445,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); @@ -4474,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); @@ -4502,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; @@ -4511,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))); @@ -4525,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; @@ -4540,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))); @@ -4553,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; @@ -4562,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))); @@ -4576,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; @@ -4588,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))); @@ -4601,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; } @@ -4618,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; } @@ -4633,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; } @@ -4648,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; } @@ -4667,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; @@ -4683,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 @@ -4695,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) @@ -4718,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; @@ -4735,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 */ @@ -4750,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; @@ -4792,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; @@ -4821,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 */ @@ -4838,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; @@ -4855,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; @@ -4871,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) { @@ -4904,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)) @@ -4928,19 +5390,30 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) * * Return a code reference. */ -static SV *retrieve_code(stcxt_t *cxt, char *cname) +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; + int type, count, tagnum; SV *cv; - SV *sv, *text, *sub, *errsv; + 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 */ @@ -4948,10 +5421,10 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) GETMARK(type); switch (type) { case SX_SCALAR: - text = retrieve_scalar(cxt, cname); + text = retrieve_scalar(aTHX_ cxt, cname); break; case SX_LSCALAR: - text = retrieve_lscalar(cxt, cname); + text = retrieve_lscalar(aTHX_ cxt, cname); break; default: CROAK(("Unexpected type %d in retrieve_code\n", type)); @@ -4962,7 +5435,7 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) */ sub = newSVpvn("sub ", 4); - sv_catpv(sub, SvPV(text, PL_na)); /* XXX no sv_catsv! */ + sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */ SvREFCNT_dec(text); /* @@ -4982,6 +5455,8 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) 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; } } @@ -4991,7 +5466,7 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) { SV* errsv = get_sv("@", TRUE); - sv_setpv(errsv, ""); /* clear $@ */ + sv_setpvn(errsv, "", 0); /* clear $@ */ PUSHMARK(sp); XPUSHs(sv_2mortal(newSVsv(sub))); PUTBACK; @@ -5001,16 +5476,17 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) CROAK(("Unexpected return value from $Storable::Eval callback\n")); cv = POPs; if (SvTRUE(errsv)) { - CROAK(("code %s caused an error: %s", SvPV(sub, PL_na), SvPV(errsv, PL_na))); + CROAK(("code %s caused an error: %s", + SvPV_nolen(sub), SvPV_nolen(errsv))); } PUTBACK; } else { - cv = eval_pv(SvPV(sub, PL_na), TRUE); + 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(sub, PL_na))); + CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub))); } SvREFCNT_inc(sv); /* XXX seems to be necessary */ @@ -5018,8 +5494,9 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) FREETMPS; LEAVE; + /* fix up the dummy entry... */ + av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); - SEEN(sv, cname); return sv; #endif } @@ -5034,7 +5511,7 @@ static SV *retrieve_code(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; @@ -5051,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 @@ -5068,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) @@ -5094,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; @@ -5102,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)); @@ -5113,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 */ @@ -5140,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. @@ -5155,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) @@ -5191,7 +5668,7 @@ 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) { /* The worst case for a malicious header would be old magic (which is longer), major, minor, byteorder length byte of 255, 255 bytes of @@ -5207,6 +5684,7 @@ static SV *magic_check(stcxt_t *cxt) int length; int use_network_order; int use_NV_size; + int old_magic = 0; int version_major; int version_minor = 0; @@ -5240,6 +5718,7 @@ static SV *magic_check(stcxt_t *cxt) if (memNE(buf, old_magicstr, old_len)) CROAK(("File is not a perl storable")); + old_magic++; current = buf + old_len; } use_network_order = *current; @@ -5251,9 +5730,14 @@ static SV *magic_check(stcxt_t *cxt) * indicate the version number of the binary, and therefore governs the * setting of sv_retrieve_vtbl. See magic_write(). */ - - version_major = use_network_order >> 1; - cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve; + if (old_magic && use_network_order > 1) { + /* 0.1 dump - use_network_order is really byte order length */ + version_major = -1; + } + else { + version_major = use_network_order >> 1; + } + cxt->retrieve_vtbl = (SV*(**)(pTHX_ stcxt_t *cxt, const char *cname)) (version_major > 0 ? sv_retrieve : sv_old_retrieve); TRACEME(("magic_check: netorder = 0x%x", use_network_order)); @@ -5316,7 +5800,12 @@ static SV *magic_check(stcxt_t *cxt) /* In C truth is 1, falsehood is 0. Very convienient. */ use_NV_size = version_major >= 2 && version_minor >= 2; - GETMARK(c); + if (version_major >= 0) { + GETMARK(c); + } + else { + c = use_network_order; + } length = c + 3 + use_NV_size; READ(buf, length); /* Not null-terminated */ @@ -5348,7 +5837,7 @@ static SV *magic_check(stcxt_t *cxt) /* sizeof(char *) */ if ((int) *current != sizeof(char *)) - CROAK(("Pointer integer size is not compatible")); + CROAK(("Pointer size is not compatible")); if (use_NV_size) { /* sizeof(NV) */ @@ -5366,7 +5855,7 @@ static SV *magic_check(stcxt_t *cxt) * 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; @@ -5475,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 */ @@ -5526,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) @@ -5556,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 @@ -5564,7 +6054,7 @@ static SV *do_retrieve( */ if (cxt->entry) - cxt = allocate_context(cxt); + cxt = allocate_context(aTHX_ cxt); cxt->entry++; @@ -5581,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. @@ -5594,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")); @@ -5613,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. @@ -5632,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. @@ -5642,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")", @@ -5660,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; } @@ -5704,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); } /* @@ -5715,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); } /*** @@ -5734,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; @@ -5749,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 */ /* @@ -5787,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))); @@ -5834,7 +6389,13 @@ 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. */ @@ -5843,42 +6404,88 @@ BOOT: #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