*/
/*
- * $Id: Storable.xs,v 1.0.1.6 2001/01/03 09:40:40 ram Exp $
+ * $Id: Storable.xs,v 1.0.1.8 2001/03/15 00:20:55 ram Exp $
*
* Copyright (c) 1995-2000, Raphael Manfredi
*
* in the README file that comes with the distribution.
*
* $Log: Storable.xs,v $
+ * Revision 1.0.1.8 2001/03/15 00:20:55 ram
+ * patch11: last version was wrongly compiling with assertions on
+ *
+ * Revision 1.0.1.7 2001/02/17 12:25:26 ram
+ * patch8: now bless objects ASAP at retrieve time
+ * patch8: added support for blessed ref to tied structures
+ *
* Revision 1.0.1.6 2001/01/03 09:40:40 ram
* patch7: prototype and casting cleanup
* patch7: trace offending package when overloading cannot be restored
* Revision 1.0.1.3 2000/09/29 19:49:57 ram
* patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp
*
- * $Log: Storable.xs,v $
+ * Revision 1.0.1.2 2000/09/28 21:43:10 ram
+ * patch2: perls before 5.004_04 lack newSVpvn
+ *
+ * Revision 1.0.1.1 2000/09/17 16:47:49 ram
+ * patch1: now only taint retrieved data when source was tainted
+ * patch1: added support for UTF-8 strings
+ * patch1: fixed store hook bug: was allocating class id too soon
+ *
* Revision 1.0 2000/09/01 19:40:41 ram
* Baseline for first official release.
*
#include <EXTERN.h>
#include <perl.h>
-#include <patchlevel.h> /* Perl's one, needed since 5.6 */
#include <XSUB.h>
#if 0
*/
#ifndef PERL_VERSION /* For perls < 5.6 */
+#include <patchlevel.h>
#define PERL_VERSION PATCHLEVEL
#ifndef newRV_noinc
#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
#endif
#ifdef DEBUGME
+
+#ifndef DASSERT
+#define DASSERT
+#endif
+
/*
* TRACEME() will only output things when the $Storable::DEBUGME is true.
*/
} while (0)
#else
#define TRACEME(x)
-#endif
+#endif /* DEBUGME */
-#ifndef DASSERT
-#define DASSERT
-#endif
#ifdef DASSERT
#define ASSERT(x,y) do { \
if (!(x)) { \
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 */
- I32 tagnum; /* incremented at store time for each seen object */
- I32 classnum; /* incremented at store time for each seen classname */
+ IV tagnum; /* incremented at store time for each seen object */
+ IV classnum; /* incremented at store time for each seen classname */
int netorder; /* true if network order used */
int s_tainted; /* true if input source is tainted, at retrieve time */
int forgive_me; /* whether to be forgiving... */
#define SHF_HAS_LIST 0x80
/*
- * Types for SX_HOOK (2 bits).
+ * Types for SX_HOOK (last 2 bits in flags).
*/
#define SHT_SCALAR 0
#define SHT_ARRAY 1
#define SHT_HASH 2
+#define SHT_EXTRA 3 /* Read extra byte for type */
+
+/*
+ * The following are held in the "extra byte"...
+ */
+
+#define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */
+#define SHT_TARRAY 5 /* 4 + 1 -- tied array */
+#define SHT_THASH 6 /* 4 + 2 -- tied hash */
/*
* Before 0.6, the magic string was "perl-store" (binary version number 0).
static char magicstr[] = "pst0"; /* Used as a magic number */
#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
-#define STORABLE_BIN_MINOR 3 /* Binary minor "version" */
+#define STORABLE_BIN_MINOR 4 /* Binary minor "version" */
/*
* Useful store shortcuts...
#define GETMARK(x) do { \
if (!cxt->fio) \
MBUF_GETC(x); \
-! else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \
+ else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \
return (SV *) 0; \
} while (0)
* given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
* we'll therefore know where it has been retrieved and will be able to
* share the same reference, as in the original stored memory image.
+ *
+ * We also need to bless objects ASAP for hooks (which may compute "ref $x"
+ * on the objects given to STORABLE_thaw and expect that to be defined), and
+ * also for overloaded objects (for which we might not find the stash if the
+ * object is not blessed yet--this might occur for overloaded objects that
+ * refer to themselves indirectly: if we blessed upon return from a sub
+ * retrieve(), the SX_OBJECT marker we'd found could not have overloading
+ * restored on it because the underlying object would not be blessed yet!).
+ *
+ * To achieve that, the class name of the last retrieved object is passed down
+ * recursively, and the first SEEN() call for which the class name is not NULL
+ * will bless the object.
*/
-#define SEEN(y) do { \
+#define SEEN(y,c) do { \
if (!y) \
return (SV *) 0; \
if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \
return (SV *) 0; \
TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \
- PTR2UV(y), SvREFCNT(y)-1)); \
+ PTR2UV(y), SvREFCNT(y)-1)); \
+ if (c) \
+ BLESS((SV *) (y), c); \
} while (0)
/*
} while (0)
static int store();
-static SV *retrieve();
+static SV *retrieve(stcxt_t *cxt, char *cname);
/*
* Dynamic dispatching table for SV store.
* Dynamic dispatching tables for SV retrieval.
*/
-static SV *retrieve_lscalar(stcxt_t *cxt);
-static SV *retrieve_lutf8str(stcxt_t *cxt);
-static SV *old_retrieve_array(stcxt_t *cxt);
-static SV *old_retrieve_hash(stcxt_t *cxt);
-static SV *retrieve_ref(stcxt_t *cxt);
-static SV *retrieve_undef(stcxt_t *cxt);
-static SV *retrieve_integer(stcxt_t *cxt);
-static SV *retrieve_double(stcxt_t *cxt);
-static SV *retrieve_byte(stcxt_t *cxt);
-static SV *retrieve_netint(stcxt_t *cxt);
-static SV *retrieve_scalar(stcxt_t *cxt);
-static SV *retrieve_utf8str(stcxt_t *cxt);
-static SV *retrieve_tied_array(stcxt_t *cxt);
-static SV *retrieve_tied_hash(stcxt_t *cxt);
-static SV *retrieve_tied_scalar(stcxt_t *cxt);
-static SV *retrieve_other(stcxt_t *cxt);
-
-static SV *(*sv_old_retrieve[])(stcxt_t *cxt) = {
+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) = {
0, /* SX_OBJECT -- entry unused dynamically */
retrieve_lscalar, /* SX_LSCALAR */
old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */
retrieve_other, /* SX_ERROR */
};
-static SV *retrieve_array(stcxt_t *cxt);
-static SV *retrieve_hash(stcxt_t *cxt);
-static SV *retrieve_sv_undef(stcxt_t *cxt);
-static SV *retrieve_sv_yes(stcxt_t *cxt);
-static SV *retrieve_sv_no(stcxt_t *cxt);
-static SV *retrieve_blessed(stcxt_t *cxt);
-static SV *retrieve_idx_blessed(stcxt_t *cxt);
-static SV *retrieve_hook(stcxt_t *cxt);
-static SV *retrieve_overloaded(stcxt_t *cxt);
-static SV *retrieve_tied_key(stcxt_t *cxt);
-static SV *retrieve_tied_idx(stcxt_t *cxt);
-
-static SV *(*sv_retrieve[])(stcxt_t *cxt) = {
+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 *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = {
0, /* SX_OBJECT -- entry unused dynamically */
retrieve_lscalar, /* SX_LSCALAR */
retrieve_array, /* SX_ARRAY */
*/
hv_iterinit(cxt->hseen);
- while (he = hv_iternext(cxt->hseen))
+ while ((he = hv_iternext(cxt->hseen)))
HeVAL(he) = &PL_sv_undef;
hv_iterinit(cxt->hclass);
- while (he = hv_iternext(cxt->hclass))
+ while ((he = hv_iternext(cxt->hclass)))
HeVAL(he) = &PL_sv_undef;
/*
{
GV *gv;
SV *sv;
- SV **svh;
/*
* The following code is the same as the one performed by UNIVERSAL::can
continue;
}
TRACEME(("(#%d) item", i));
- if (ret = store(cxt, *sav))
+ if ((ret = store(cxt, *sav)))
return ret;
}
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
- if (ret = store(cxt, val))
+ if ((ret = store(cxt, val)))
goto out;
/*
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
- if (ret = store(cxt, val))
+ if ((ret = store(cxt, val)))
goto out;
/*
* accesses on the retrieved object will indeed call the magic methods...
*/
- if (ret = store(cxt, mg->mg_obj))
+ if ((ret = store(cxt, mg->mg_obj)))
return ret;
TRACEME(("ok (tied)"));
PUTMARK(SX_TIED_KEY);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
- if (ret = store(cxt, mg->mg_obj))
+ if ((ret = store(cxt, mg->mg_obj)))
return ret;
TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
- if (ret = store(cxt, (SV *) mg->mg_ptr))
+ if ((ret = store(cxt, (SV *) mg->mg_ptr)))
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))
+ if ((ret = store(cxt, mg->mg_obj)))
return ret;
TRACEME(("store_tied_item: storing IDX %d", idx));
* that same header being repeated between serialized objects obtained through
* recursion, until we reach flags indicating no recursion, at which point
* we know we've resynchronized with a single layout, after <flags>.
+ *
+ * When storing a blessed ref to a tied variable, the following format is
+ * used:
+ *
+ * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
+ *
+ * The first <flags> indication carries an object of type SHT_EXTRA, and the
+ * real object type is held in the <extra> flag. At the very end of the
+ * serialization stream, the underlying magic object is serialized, just like
+ * any other tied variable.
*/
static int store_hook(
stcxt_t *cxt,
I32 classnum;
int ret;
int clone = cxt->optype & ST_CLONE;
+ char mtype = 0; /* for blessed ref to tied structures */
+ unsigned char eflags = 0; /* used when object type is SHT_EXTRA */
TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum));
case svis_HASH:
obj_type = SHT_HASH;
break;
+ case svis_TIED:
+ /*
+ * Produced by a blessed ref to a tied data structure, $o in the
+ * following Perl code.
+ *
+ * my %h;
+ * tie %h, 'FOO';
+ * my $o = bless \%h, 'BAR';
+ *
+ * Signal the tie-ing magic by setting the object type as SHT_EXTRA
+ * (since we have only 2 bits in <flags> to store the type), and an
+ * <extra> byte flag will be emitted after the FIRST <flags> in the
+ * stream, carrying what we put in `eflags'.
+ */
+ obj_type = SHT_EXTRA;
+ switch (SvTYPE(sv)) {
+ case SVt_PVHV:
+ eflags = (unsigned char) SHT_THASH;
+ mtype = 'P';
+ break;
+ case SVt_PVAV:
+ eflags = (unsigned char) SHT_TARRAY;
+ mtype = 'P';
+ break;
+ default:
+ eflags = (unsigned char) SHT_TSCALAR;
+ mtype = 'q';
+ break;
+ }
+ break;
default:
CROAK(("Unexpected object type (%d) in store_hook()", type));
}
* Serialize entry if not done already, and get its tag.
*/
- if (svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE))
+ if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
goto sv_seen; /* Avoid moving code too far to the right */
TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv)));
* others, in case those would point back at that object.
*/
- /* [SX_HOOK] <flags> <object>*/
- if (!recursed++)
+ /* [SX_HOOK] <flags> [<extra>] <object>*/
+ if (!recursed++) {
PUTMARK(SX_HOOK);
- PUTMARK(flags);
+ PUTMARK(flags);
+ if (obj_type == SHT_EXTRA)
+ PUTMARK(eflags);
+ } else
+ PUTMARK(flags);
- if (ret = store(cxt, xsv)) /* Given by hook for us to store */
+ if ((ret = store(cxt, xsv))) /* Given by hook for us to store */
return ret;
svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
"class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d",
recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
- /* SX_HOOK <flags> */
- if (!recursed)
+ /* SX_HOOK <flags> [<extra>] */
+ if (!recursed) {
PUTMARK(SX_HOOK);
- PUTMARK(flags);
+ PUTMARK(flags);
+ if (obj_type == SHT_EXTRA)
+ PUTMARK(eflags);
+ } else
+ PUTMARK(flags);
/* <len> <classname> or <index> */
if (flags & SHF_IDX_CLASSNAME) {
av_undef(av);
sv_free((SV *) av);
+ /*
+ * If object was tied, need to insert serialization of the magic object.
+ */
+
+ if (obj_type == SHT_EXTRA) {
+ MAGIC *mg;
+
+ if (!(mg = mg_find(sv, mtype))) {
+ int svt = SvTYPE(sv);
+ CROAK(("No magic '%c' found while storing ref to tied %s with hook",
+ mtype, (svt == SVt_PVHV) ? "hash" :
+ (svt == SVt_PVAV) ? "array" : "scalar"));
+ }
+
+ TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf,
+ PTR2UV(mg->mg_obj), PTR2UV(sv)));
+
+ /*
+ * [<magic object>]
+ */
+
+ if ((ret = store(cxt, mg->mg_obj)))
+ return ret;
+ }
+
return 0;
}
* Store placeholder string as a scalar instead...
*/
- (void) sprintf(buf, "You lost %s(0x%"UVxf")\0", sv_reftype(sv, FALSE),
- PTR2UV(sv));
+ (void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE),
+ PTR2UV(sv), (char)0);
len = strlen(buf);
STORE_SCALAR(buf, len);
{
SV **svh;
int ret;
- SV *tag;
int type;
HV *hseen = cxt->hseen;
* 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)
+static SV *retrieve_other(stcxt_t *cxt, 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)
+static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname)
{
I32 idx;
char *class;
SV *sv;
TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum));
+ ASSERT(!cname, ("no bless-into class given here, got %s", cname));
GETMARK(idx); /* Index coded on a single char? */
if (idx & 0x80)
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
- CROAK(("Class name #%d should have been seen already", (int)idx));
+ CROAK(("Class name #%"IVdf" should have been seen already",
+ (IV)idx));
class = SvPVX(*sva); /* We know it's a PV, by construction */
* Retrieve object and bless it.
*/
- sv = retrieve(cxt);
- if (sv)
- BLESS(sv, class);
+ sv = retrieve(cxt, class); /* 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)
+static SV *retrieve_blessed(stcxt_t *cxt, char *cname)
{
I32 len;
SV *sv;
char *class = buf;
TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
+ ASSERT(!cname, ("no bless-into class given here, got %s", cname));
/*
* Decode class name length and read that name.
* 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));
+
if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len)))
return (SV *) 0;
* Retrieve object and bless it.
*/
- sv = retrieve(cxt);
- if (sv) {
- BLESS(sv, class);
- if (class != buf)
- Safefree(class);
- }
+ sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */
+ if (class != buf)
+ Safefree(class);
return sv;
}
* When recursion was involved during serialization of the object, there
* is an unknown amount of serialized objects after the SX_HOOK mark. Until
* we reach a <flags> marker with the recursion bit cleared.
+ *
+ * If the first <flags> byte contains a type of SHT_EXTRA, then the real type
+ * is held in the <extra> byte, and if the object is tied, the serialized
+ * magic object comes at the very end:
+ *
+ * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
+ *
+ * This means the STORABLE_thaw hook will NOT get a tied variable during its
+ * processing (since we won't have seen the magic object by the time the hook
+ * is called). See comments below for why it was done that way.
*/
-static SV *retrieve_hook(stcxt_t *cxt)
+static SV *retrieve_hook(stcxt_t *cxt, char *cname)
{
I32 len;
char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
SV *sv;
SV *rv;
int obj_type;
- I32 classname;
int clone = cxt->optype & ST_CLONE;
+ char mtype = '\0';
+ unsigned int extra_type = 0;
TRACEME(("retrieve_hook (#%d)", cxt->tagnum));
+ ASSERT(!cname, ("no bless-into class given here, got %s", cname));
/*
* Read flags, which tell us about the type, and whether we need to recurse.
case SHT_HASH:
sv = (SV *) newHV();
break;
+ case SHT_EXTRA:
+ /*
+ * Read <extra> flag to know the type of the object.
+ * Record associated magic type for later.
+ */
+ GETMARK(extra_type);
+ switch (extra_type) {
+ case SHT_TSCALAR:
+ sv = newSV(0);
+ mtype = 'q';
+ break;
+ case SHT_TARRAY:
+ sv = (SV *) newAV();
+ mtype = 'P';
+ break;
+ case SHT_THASH:
+ sv = (SV *) newHV();
+ mtype = 'P';
+ break;
+ default:
+ return retrieve_other(cxt, 0); /* Let it croak */
+ }
+ break;
default:
- return retrieve_other(cxt); /* Let it croak */
+ return retrieve_other(cxt, 0); /* Let it croak */
}
- SEEN(sv);
+ SEEN(sv, 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);
+ rv = retrieve(cxt, 0);
if (!rv)
return (SV *) 0;
TRACEME(("retrieve_hook back with rv=0x%"UVxf,
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
- CROAK(("Class name #%d should have been seen already", (int)idx));
+ 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));
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
- CROAK(("Object #%d should have been retrieved already", (int)tag));
+ CROAK(("Object #%"IVdf" should have been retrieved already", (IV)tag));
xsv = *svh;
ary[i] = SvREFCNT_inc(xsv);
}
if (!(flags & SHF_IDX_CLASSNAME) && class != buf)
Safefree(class);
+ /*
+ * If we had an <extra> type, then the object was not as simple, and
+ * we need to restore extra magic now.
+ */
+
+ if (!extra_type)
+ return sv;
+
+ TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv)));
+
+ rv = retrieve(cxt, 0); /* Retrieve <magic object> */
+
+ TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf,
+ PTR2UV(rv), PTR2UV(sv)));
+
+ switch (extra_type) {
+ case SHT_TSCALAR:
+ sv_upgrade(sv, SVt_PVMG);
+ break;
+ case SHT_TARRAY:
+ sv_upgrade(sv, SVt_PVAV);
+ AvREAL_off((AV *)sv);
+ break;
+ case SHT_THASH:
+ sv_upgrade(sv, SVt_PVHV);
+ break;
+ default:
+ CROAK(("Forgot to deal with extra type %d", extra_type));
+ break;
+ }
+
+ /*
+ * Adding the magic only now, well after the STORABLE_thaw hook was called
+ * means the hook cannot know it deals with an object whose variable is
+ * tied. But this is happening when retrieving $o in the following case:
+ *
+ * my %h;
+ * tie %h, 'FOO';
+ * my $o = bless \%h, 'BAR';
+ *
+ * The 'BAR' class is NOT the one where %h is tied into. Therefore, as
+ * far as the 'BAR' class is concerned, the fact that %h is not a REAL
+ * hash but a tied one should not matter at all, and remain transparent.
+ * This means the magic must be restored by Storable AFTER the hook is
+ * called.
+ *
+ * That looks very reasonable to me, but then I've come up with this
+ * after a bug report from David Nesting, who was trying to store such
+ * an object and caused Storable to fail. And unfortunately, it was
+ * also the easiest way to retrofit support for blessed ref to tied objects
+ * into the existing design. -- RAM, 17/02/2001
+ */
+
+ sv_magic(sv, rv, mtype, Nullch, 0);
+ SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */
+
return sv;
}
* Retrieve reference to some other scalar.
* Layout is SX_REF <object>, with SX_REF already read.
*/
-static SV *retrieve_ref(stcxt_t *cxt)
+static SV *retrieve_ref(stcxt_t *cxt, char *cname)
{
SV *rv;
SV *sv;
*/
rv = NEWSV(10002, 0);
- SEEN(rv); /* Will return if rv is null */
- sv = retrieve(cxt); /* Retrieve <object> */
+ SEEN(rv, cname); /* Will return if rv is null */
+ sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* 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)
+static SV *retrieve_overloaded(stcxt_t *cxt, char *cname)
{
SV *rv;
SV *sv;
*/
rv = NEWSV(10002, 0);
- SEEN(rv); /* Will return if rv is null */
- sv = retrieve(cxt); /* Retrieve <object> */
+ SEEN(rv, cname); /* Will return if rv is null */
+ sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* Retrieve tied array
* Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read.
*/
-static SV *retrieve_tied_array(stcxt_t *cxt)
+static SV *retrieve_tied_array(stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv); /* Will return if tv is null */
- sv = retrieve(cxt); /* Retrieve <object> */
+ SEEN(tv, cname); /* Will return if tv is null */
+ sv = retrieve(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)
+static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv); /* Will return if tv is null */
- sv = retrieve(cxt); /* Retrieve <object> */
+ SEEN(tv, cname); /* Will return if tv is null */
+ sv = retrieve(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(cxt)
-stcxt_t *cxt;
+static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv); /* Will return if rv is null */
- sv = retrieve(cxt); /* Retrieve <object> */
+ SEEN(tv, cname); /* Will return if rv is null */
+ sv = retrieve(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)
+static SV *retrieve_tied_key(stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv); /* Will return if tv is null */
- sv = retrieve(cxt); /* Retrieve <object> */
+ SEEN(tv, cname); /* Will return if tv is null */
+ sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
- key = retrieve(cxt); /* Retrieve <key> */
+ key = retrieve(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)
+static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv); /* Will return if tv is null */
- sv = retrieve(cxt); /* Retrieve <object> */
+ SEEN(tv, cname); /* Will return if tv is null */
+ sv = retrieve(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)
+static SV *retrieve_lscalar(stcxt_t *cxt, char *cname)
{
I32 len;
SV *sv;
*/
sv = NEWSV(10002, len);
- SEEN(sv); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
/*
* 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)
+static SV *retrieve_scalar(stcxt_t *cxt, char *cname)
{
int len;
SV *sv;
*/
sv = NEWSV(10002, len);
- SEEN(sv); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname); /* 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)
+static SV *retrieve_utf8str(stcxt_t *cxt, char *cname)
{
SV *sv;
TRACEME(("retrieve_utf8str"));
- sv = retrieve_scalar(cxt);
+ sv = retrieve_scalar(cxt, cname);
if (sv)
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)
+static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname)
{
SV *sv;
TRACEME(("retrieve_lutf8str"));
- sv = retrieve_lscalar(cxt);
+ sv = retrieve_lscalar(cxt, cname);
if (sv)
SvUTF8_on(sv);
* Retrieve defined integer.
* Layout is SX_INTEGER <data>, whith SX_INTEGER already read.
*/
-static SV *retrieve_integer(stcxt_t *cxt)
+static SV *retrieve_integer(stcxt_t *cxt, char *cname)
{
SV *sv;
IV iv;
READ(&iv, sizeof(iv));
sv = newSViv(iv);
- SEEN(sv); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname); /* 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)
+static SV *retrieve_netint(stcxt_t *cxt, char *cname)
{
SV *sv;
I32 iv;
sv = newSViv(iv);
TRACEME(("network integer (as-is) %d", iv));
#endif
- SEEN(sv); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname); /* 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)
+static SV *retrieve_double(stcxt_t *cxt, char *cname)
{
SV *sv;
NV nv;
READ(&nv, sizeof(nv));
sv = newSVnv(nv);
- SEEN(sv); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname); /* 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)
+static SV *retrieve_byte(stcxt_t *cxt, char *cname)
{
SV *sv;
int siv;
+ signed char tmp; /* must use temp var to work around
+ an AIX compiler bug --H.Merijn Brand */
TRACEME(("retrieve_byte (#%d)", cxt->tagnum));
GETMARK(siv);
TRACEME(("small integer read as %d", (unsigned char) siv));
- sv = newSViv((unsigned char) siv - 128);
- SEEN(sv); /* Associate this new scalar with tag "tagnum" */
+ tmp = ((unsigned char)siv) - 128;
+ sv = newSViv (tmp);
+
+ SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
- TRACEME(("byte %d", (unsigned char) siv - 128));
+ TRACEME(("byte %d", tmp));
TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv)));
return sv;
*
* Return the undefined value.
*/
-static SV *retrieve_undef(stcxt_t *cxt)
+static SV *retrieve_undef(stcxt_t *cxt, char *cname)
{
SV* sv;
TRACEME(("retrieve_undef"));
sv = newSV(0);
- SEEN(sv);
+ SEEN(sv, cname);
return sv;
}
*
* Return the immortal undefined value.
*/
-static SV *retrieve_sv_undef(stcxt_t *cxt)
+static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname)
{
SV *sv = &PL_sv_undef;
TRACEME(("retrieve_sv_undef"));
- SEEN(sv);
+ SEEN(sv, cname);
return sv;
}
*
* Return the immortal yes value.
*/
-static SV *retrieve_sv_yes(stcxt_t *cxt)
+static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname)
{
SV *sv = &PL_sv_yes;
TRACEME(("retrieve_sv_yes"));
- SEEN(sv);
+ SEEN(sv, cname);
return sv;
}
*
* Return the immortal no value.
*/
-static SV *retrieve_sv_no(stcxt_t *cxt)
+static SV *retrieve_sv_no(stcxt_t *cxt, char *cname)
{
SV *sv = &PL_sv_no;
TRACEME(("retrieve_sv_no"));
- SEEN(sv);
+ SEEN(sv, cname);
return sv;
}
*
* When we come here, SX_ARRAY has been read already.
*/
-static SV *retrieve_array(stcxt_t *cxt)
+static SV *retrieve_array(stcxt_t *cxt, char *cname)
{
I32 len;
I32 i;
RLEN(len);
TRACEME(("size = %d", len));
av = newAV();
- SEEN(av); /* Will return if array not allocated nicely */
+ SEEN(av, cname); /* 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); /* Retrieve item */
+ sv = retrieve(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)
+static SV *retrieve_hash(stcxt_t *cxt, char *cname)
{
I32 len;
I32 size;
I32 i;
HV *hv;
SV *sv;
- static SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
TRACEME(("retrieve_hash (#%d)", cxt->tagnum));
RLEN(len);
TRACEME(("size = %d", len));
hv = newHV();
- SEEN(hv); /* Will return if table not allocated properly */
+ SEEN(hv, cname); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
*/
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt);
+ sv = retrieve(cxt, 0);
if (!sv)
return (SV *) 0;
*
* When we come here, SX_ARRAY has been read already.
*/
-static SV *old_retrieve_array(stcxt_t *cxt)
+static SV *old_retrieve_array(stcxt_t *cxt, char *cname)
{
I32 len;
I32 i;
RLEN(len);
TRACEME(("size = %d", len));
av = newAV();
- SEEN(av); /* Will return if array not allocated nicely */
+ SEEN(av, 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); /* Will croak out */
+ (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */
TRACEME(("(#%d) item", i));
- sv = retrieve(cxt); /* Retrieve item */
+ sv = retrieve(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)
+static SV *old_retrieve_hash(stcxt_t *cxt, char *cname)
{
I32 len;
I32 size;
I32 i;
HV *hv;
- SV *sv;
+ SV *sv=NULL;
int c;
static SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
RLEN(len);
TRACEME(("size = %d", len));
hv = newHV();
- SEEN(hv); /* Will return if table not allocated properly */
+ SEEN(hv, 0); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
sv = SvREFCNT_inc(sv_h_undef);
} else if (c == SX_VALUE) {
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt);
+ sv = retrieve(cxt, 0);
if (!sv)
return (SV *) 0;
} else
- (void) retrieve_other((stcxt_t *) 0); /* Will croak out */
+ (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */
/*
* Get key.
GETMARK(c);
if (c != SX_KEY)
- (void) retrieve_other((stcxt_t *) 0); /* Will croak out */
+ (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */
RLEN(size); /* Get key size */
KBUFCHK(size); /* Grow hash key read pool if needed */
if (size)
* information to check.
*/
- if (cxt->netorder = (use_network_order & 0x1))
+ if ((cxt->netorder = (use_network_order & 0x1)))
return &PL_sv_undef; /* No byte ordering info */
sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
* 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)
+static SV *retrieve(stcxt_t *cxt, char *cname)
{
int type;
SV **svh;
I32 tagn;
svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
if (!svh)
- CROAK(("Old tag 0x%x should have been mapped already", (unsigned)tag));
+ CROAK(("Old tag 0x%"UVxf" should have been mapped already", (UV)tag));
tagn = SvIV(*svh); /* Mapped tag number computed earlier below */
/*
svh = av_fetch(cxt->aseen, tagn, FALSE);
if (!svh)
- CROAK(("Object #%d should have been retrieved already", (int)tagn));
+ CROAK(("Object #%"IVdf" should have been retrieved already", (IV)tagn));
sv = *svh;
TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
- CROAK(("Object #%d should have been retrieved already", (int)tag));
+ CROAK(("Object #%"IVdf" should have been retrieved already",
+ (IV)tag));
sv = *svh;
TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
* Okay, first time through for this one.
*/
- sv = RETRIEVE(cxt, type)(cxt);
+ sv = RETRIEVE(cxt, type)(cxt, cname);
if (!sv)
return (SV *) 0; /* Failed */
ASSERT(is_retrieving(), ("within retrieve operation"));
- sv = retrieve(cxt); /* Recursively retrieve object, get root SV */
+ sv = retrieve(cxt, 0); /* Recursively retrieve object, get root SV */
/*
* Final cleanup.
projects / p5sagit/p5-mst-13.2.git / blobdiff