*
*/
+#define PERL_NO_GET_CONTEXT /* we want efficiency */
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#ifndef PATCHLEVEL
-# include <patchlevel.h> /* Perl's one, needed since 5.6 */
-# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
-# include <could_not_find_Perl_patchlevel.h>
-# endif
+#include <patchlevel.h> /* Perl's one, needed since 5.6 */
#endif
-#ifndef NETWARE
-#if 0
-#define DEBUGME /* Debug mode, turns assertions on as well */
-#define DASSERT /* Assertion mode */
+#if !defined(PERL_VERSION) || PERL_VERSION < 8
+#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
#endif
#endif
+#ifndef SvRV_set
+#define SvRV_set(sv, val) \
+ STMT_START { \
+ assert(SvTYPE(sv) >= SVt_RV); \
+ (((XRV*)SvANY(sv))->xrv_rv = (val)); \
+ } STMT_END
+#endif
+
+#ifndef PERL_UNUSED_DECL
+# ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+# else
+# define PERL_UNUSED_DECL
+# endif
+#endif
+
+#ifndef dNOOP
+#define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef dVAR
+#define dVAR dNOOP
+#endif
+
+#ifndef HvRITER_set
+# define HvRITER_set(hv,r) (HvRITER(hv) = r)
+#endif
+#ifndef HvEITER_set
+# define HvEITER_set(hv,r) (HvEITER(hv) = r)
+#endif
+
+#ifndef HvRITER_get
+# define HvRITER_get HvRITER
+#endif
+#ifndef HvEITER_get
+# define HvEITER_get HvEITER
+#endif
+
+#ifndef HvNAME_get
+#define HvNAME_get HvNAME
+#endif
+
+#ifndef HvPLACEHOLDERS_get
+# define HvPLACEHOLDERS_get HvPLACEHOLDERS
+#endif
+
#ifdef DEBUGME
#ifndef DASSERT
#define 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.
#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
#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 */
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;
#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
#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))
+#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) \
* 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)); \
stash = gv_stashpv((p), TRUE); \
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)
+
+#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 */
-static int store();
-static SV *retrieve(stcxt_t *cxt, char *cname);
+#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])
* 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.
*
* 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 */
}
/*
* Initialize a new store context for real recursion.
*/
static void init_store_context(
+ pTHX_
stcxt_t *cxt,
PerlIO *f,
int optype,
* 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
*/
#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
*
* Clean store context by
*/
-static void clean_store_context(stcxt_t *cxt)
+static void clean_store_context(pTHX_ stcxt_t *cxt)
{
HE *he;
* 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);
* -- 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;
*
* 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"));
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
? 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 */
*
* 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"));
av_undef(aseen);
sv_free((SV *) aseen);
}
+ cxt->where_is_undef = -1;
if (cxt->aclass) {
AV *aclass = cxt->aclass;
*
* 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"));
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);
* 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;
* 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);
*
* Tells whether we're in the middle of a store operation.
*/
-int is_storing(void)
+static int is_storing(pTHX)
{
dSTCXT;
*
* Tells whether we're in the middle of a retrieve operation.
*/
-int is_retrieving(void)
+static int is_retrieving(pTHX)
{
dSTCXT;
* 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;
* nor its ancestors know about the method.
*/
static SV *pkg_fetchmeth(
+ pTHX_
HV *cache,
HV *pkg,
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
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));
}
/*
* 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;
}
* Force cached value to be undef: hook ignored even if present.
*/
static void pkg_hide(
+ pTHX_
HV *cache,
HV *pkg,
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);
}
/*
* Discard cached value: a whole fetch loop will be retried at next lookup.
*/
static void pkg_uncache(
+ pTHX_
HV *cache,
HV *pkg,
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);
}
/*
* know about the method.
*/
static SV *pkg_can(
+ pTHX_
HV *cache,
HV *pkg,
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
* 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 */
}
/*
* Propagates the single returned value if not called in void context.
*/
static SV *scalar_call(
+ pTHX_
SV *obj,
SV *hook,
int cloning,
* Returns the list of returned values in an array.
*/
static AV *array_call(
+ pTHX_
SV *obj,
SV *hook,
int cloning)
* 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 */
* Store a reference.
* Layout is SX_REF <object> or SX_OVERLOAD <object>.
*/
-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);
}
/*
* If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
* Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
*/
-static int store_scalar(stcxt_t *cxt, SV *sv)
+static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
{
IV iv;
char *pv;
* Layout is SX_ARRAY <size> followed by each item, in increading index order.
* Each item is stored as <object>.
*/
-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;
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;
}
return 0;
}
+
+#if (PATCHLEVEL <= 6)
+
/*
* sortcmp
*
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
* 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);
* 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);
/*
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.
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_placeholder)
- flags |= SHV_K_PLACEHOLDER;
+ if ((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) {
+ flags |= SHV_K_LOCKED;
+ }
keyval = SvPV(key, keylen_tmp);
keylen = keylen_tmp;
*/
for (i = 0; i < len; i++) {
- char *key;
+ char *key = 0;
I32 len;
unsigned char flags;
#ifdef HV_ITERNEXT_WANTPLACEHOLDERS
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_placeholder)
- flags |= SHV_K_PLACEHOLDER;
hek = HeKEY_hek(he);
len = HEK_LEN(hek);
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)
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;
}
* Layout is SX_CODE <length> 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;
(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));
ENTER;
CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
text = POPs;
- len = SvLEN(text);
+ len = SvCUR(text);
reallen = strlen(SvPV_nolen(text));
/*
*/
PUTMARK(SX_CODE);
+ cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */
TRACEME(("size = %d", len));
TRACEME(("code = %s", SvPV_nolen(text)));
* dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
* <hash object> stands for the serialization of the tied hash.
*/
-static int store_tied(stcxt_t *cxt, SV *sv)
+static int store_tied(pTHX_ stcxt_t *cxt, SV *sv)
{
MAGIC *mg;
SV *obj = NULL;
/* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */
obj = mg->mg_obj ? mg->mg_obj : newSV(0);
- if ((ret = store(cxt, obj)))
+ if ((ret = store(aTHX_ cxt, obj)))
return ret;
TRACEME(("ok (tied)"));
* SX_TIED_KEY <object> <key>
* SX_TIED_IDX <object> <index>
*/
-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;
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;
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));
* any other tied variable.
*/
static int store_hook(
+ pTHX_
stcxt_t *cxt,
SV *sv,
int type,
SV *hook)
{
I32 len;
- char *class;
+ char *classname;
STRLEN len2;
SV *ref;
AV *av;
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.
}
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:
* 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;
* 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);
}
/*
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
*/
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 = 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)));
} 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 = 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'.
*
* 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)));
}
/*
* 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));
}
/*
unsigned char clen = (unsigned char) len;
PUTMARK(clen);
}
- WRITE(class, len); /* Final \0 is omitted */
+ WRITE(classname, len); /* Final \0 is omitted */
}
/* <len2> <frozen-str> */
* [<magic object>]
*/
- 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;
}
* on the high-order bit in flag (same encoding as above for <len>).
*/
static int store_blessed(
+ pTHX_
stcxt_t *cxt,
SV *sv,
int type,
{
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
* 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;
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;
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 <object> part.
*/
- return SV_STORE(type)(cxt, sv);
+ return SV_STORE(type)(aTHX_ cxt, sv);
}
/*
* 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"));
* 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:
* object (one for which storage has started -- it may not be over if we have
* a self-referenced structure). This data set forms a stored <object>.
*/
-static int store(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)));
* -- RAM, 14/09/1999
*/
+#ifdef USE_PTR_TABLE
+ svh = 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)));
*/
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),
* Note that no byte ordering info is emitted when <network> is true, since
* integers will be emitted in network order in that case.
*/
-static int magic_write(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
* dclone() and store() is performed to memory.
*/
static int do_store(
+ pTHX_
PerlIO *f,
SV *sv,
int optype,
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
/*
* Now that STORABLE_xxx hooks exist, it is possible that they try to
*/
if (cxt->entry)
- cxt = allocate_context(cxt);
+ cxt = allocate_context(aTHX_ cxt);
cxt->entry++;
/*
* 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.
*/
* 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,
*/
if (!cxt->fio && res)
- *res = mbuf2sv();
+ *res = mbuf2sv(aTHX);
/*
* Final cleanup.
* 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));
* 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);
}
* 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);
}
/***
*
* Build a new SV out of the content of the internal memory buffer.
*/
-static SV *mbuf2sv(void)
+static SV *mbuf2sv(pTHX)
{
dSTCXT;
* 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;
* 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;
* 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 &&
* Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
* <index> can be coded on either 1 or 5 bytes.
*/
-static SV *retrieve_idx_blessed(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;
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;
}
* Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
* <len> can be coded on either 1 or 5 bytes.
*/
-static SV *retrieve_blessed(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;
TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
ASSERT(!cname, ("no bless-into class given here, got %s", 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);
}
- READ(class, len);
- class[len] = '\0'; /* Mark string end */
+ READ(classname, len);
+ 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)))
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 (classname != buf)
+ Safefree(classname);
return sv;
}
* 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;
SV *hook;
SV *sv;
SV *rv;
+ GV *attach;
int obj_type;
int clone = cxt->optype & ST_CLONE;
char mtype = '\0';
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.
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);
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 {
/*
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);
}
- READ(class, len);
- class[len] = '\0'; /* Mark string end */
+ READ(classname, len);
+ 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)))
return (SV *) 0;
}
- TRACEME(("class name: %s", class));
+ TRACEME(("class name: %s", classname));
/*
* Decode user-frozen string length and read it in an SV.
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);
}
* 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));
}
/*
*/
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);
/*
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 <extra> type, then the object was not as simple, and
TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv)));
- rv = retrieve(cxt, 0); /* Retrieve <magic object> */
+ rv = retrieve(aTHX_ cxt, 0); /* Retrieve <magic object> */
TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf,
PTR2UV(rv), PTR2UV(sv)));
* Retrieve reference to some other scalar.
* Layout is SX_REF <object>, 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;
*/
rv = NEWSV(10002, 0);
- SEEN(rv, cname); /* Will return if rv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ SEEN(rv, cname, 0); /* Will return if rv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
*/
if (cname) {
- /* Do not use sv_upgrade to preserve STASH */
- SvFLAGS(rv) &= ~SVTYPEMASK;
- SvFLAGS(rv) |= SVt_RV;
+ /* No need to do anything, as rv will already be PVMG. */
+ assert (SvTYPE(rv) >= SVt_RV);
} else {
sv_upgrade(rv, SVt_RV);
}
- SvRV(rv) = sv; /* $rv = \$sv */
+ SvRV_set(rv, sv); /* $rv = \$sv */
SvROK_on(rv);
TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv)));
}
/*
+ * retrieve_weakref
+ *
+ * Retrieve weak reference to some other scalar.
+ * Layout is SX_WEAKREF <object>, with SX_WEAKREF already read.
+ */
+static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname)
+{
+ SV *sv;
+
+ TRACEME(("retrieve_weakref (#%d)", cxt->tagnum));
+
+ sv = retrieve_ref(aTHX_ cxt, cname);
+ if (sv) {
+#ifdef SvWEAKREF
+ sv_rvweaken(sv);
+#else
+ WEAKREF_CROAK();
+#endif
+ }
+ return sv;
+}
+
+/*
* retrieve_overloaded
*
* Retrieve reference to some other scalar with overloading.
* Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read.
*/
-static SV *retrieve_overloaded(stcxt_t *cxt, char *cname)
+static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *rv;
SV *sv;
*/
rv = NEWSV(10002, 0);
- SEEN(rv, cname); /* Will return if rv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ SEEN(rv, cname, 0); /* Will return if rv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
*/
sv_upgrade(rv, SVt_RV);
- SvRV(rv) = sv; /* $rv = \$sv */
+ 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 <unknown>)",
sv_reftype(sv, FALSE),
- PTR2UV(sv),
- stash ? HvNAME(stash) : "<unknown>"));
+ 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);
}
/*
+ * retrieve_weakoverloaded
+ *
+ * Retrieve weak overloaded reference to some other scalar.
+ * Layout is SX_WEAKOVERLOADED <object>, with SX_WEAKOVERLOADED already read.
+ */
+static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname)
+{
+ SV *sv;
+
+ TRACEME(("retrieve_weakoverloaded (#%d)", cxt->tagnum));
+
+ sv = retrieve_overloaded(aTHX_ cxt, cname);
+ if (sv) {
+#ifdef SvWEAKREF
+ sv_rvweaken(sv);
+#else
+ WEAKREF_CROAK();
+#endif
+ }
+ return sv;
+}
+
+/*
* retrieve_tied_array
*
* Retrieve tied array
* Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read.
*/
-static SV *retrieve_tied_array(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if tv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* Retrieve tied hash
* Layout is SX_TIED_HASH <object>, 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;
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 <object> */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* Retrieve tied scalar
* Layout is SX_TIED_SCALAR <object>, 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, *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 <object> */
+ SEEN(tv, cname, 0); /* Will return if rv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv) {
return (SV *) 0; /* Failed */
}
* Retrieve reference to value in a tied hash.
* Layout is SX_TIED_KEY <object> <key>, with SX_TIED_KEY already read.
*/
-static SV *retrieve_tied_key(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
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 <object> */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
- key = retrieve(cxt, 0); /* Retrieve <key> */
+ key = retrieve(aTHX_ cxt, 0); /* Retrieve <key> */
if (!key)
return (SV *) 0; /* Failed */
* Retrieve reference to value in a tied array.
* Layout is SX_TIED_IDX <object> <idx>, with SX_TIED_IDX already read.
*/
-static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
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 <object> */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* The scalar is "long" in that <length> is larger than LG_SCALAR so it
* was not stored on a single byte.
*/
-static SV *retrieve_lscalar(stcxt_t *cxt, char *cname)
+static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
SV *sv;
*/
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.
* The scalar is "short" so <length> is single byte. If it is 0, there
* is no <data> 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;
*/
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.
* 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);
* 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);
* Retrieve defined integer.
* Layout is SX_INTEGER <data>, 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;
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)));
* Retrieve defined integer in network order.
* Layout is SX_NETINT <data>, 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;
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)));
* Retrieve defined double.
* Layout is SX_DOUBLE <data>, 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;
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)));
* Retrieve defined byte (small integer within the [-128, +127] range).
* Layout is SX_BYTE <data>, 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;
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)));
*
* 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;
}
*
* 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;
}
*
* 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;
}
*
* 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;
}
*
* 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;
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
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)
*
* 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;
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 */
*/
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt, 0);
+ sv = retrieve(aTHX_ cxt, 0);
if (!sv)
return (SV *) 0;
*
* 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;
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 */
*/
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt, 0);
+ sv = retrieve(aTHX_ cxt, 0);
if (!sv)
return (SV *) 0;
*/
SV *keysv;
TRACEME(("(#%d) keysv, flags=%d", i, flags));
- keysv = retrieve(cxt, 0);
+ keysv = retrieve(aTHX_ cxt, 0);
if (!keysv)
return (SV *) 0;
*
* 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;
TRACEME(("retrieve_code (#%d)", cxt->tagnum));
/*
+ * Insert dummy SV in the aseen array so that we don't screw
+ * up the tag numbers. We would just make the internal
+ * scalar an untagged item in the stream, but
+ * retrieve_scalar() calls SEEN(). So we just increase the
+ * tag number.
+ */
+ tagnum = cxt->tagnum;
+ sv = newSViv(0);
+ SEEN(sv, cname, 0);
+
+ /*
* Retrieve the source of the code reference
* as a small or large scalar
*/
GETMARK(type);
switch (type) {
case SX_SCALAR:
- text = retrieve_scalar(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));
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;
}
}
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;
FREETMPS;
LEAVE;
+ /* fix up the dummy entry... */
+ av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
- SEEN(sv, cname);
return sv;
#endif
}
*
* 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;
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
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)
*
* 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;
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));
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 */
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.
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)
* 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
int length;
int use_network_order;
int use_NV_size;
+ int old_magic = 0;
int version_major;
int version_minor = 0;
if (memNE(buf, old_magicstr, old_len))
CROAK(("File is not a perl storable"));
+ old_magic++;
current = buf + old_len;
}
use_network_order = *current;
* 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));
/* 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 */
* 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;
* 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 */
* Common routine for pretrieve and mretrieve.
*/
static SV *do_retrieve(
+ pTHX_
PerlIO *f,
SV *in,
int optype)
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
/*
* Now that STORABLE_xxx hooks exist, it is possible that they try to
*/
if (cxt->entry)
- cxt = allocate_context(cxt);
+ cxt = allocate_context(aTHX_ cxt);
cxt->entry++;
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.
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"));
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.
* 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.
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;
}
*
* 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);
}
/*
*
* 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);
}
/***
* 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;
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
+
+ /*
+ * Tied elements seem to need special handling.
+ */
+
+ if (SvTYPE(sv) == SVt_PVLV && 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 */
/*
*/
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)));
PROTOTYPES: ENABLE
BOOT:
- init_perinterp();
+{
+ HV *stash = gv_stashpvn("Storable", 8, TRUE);
+ 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. */
#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