#include <EXTERN.h>
#include <perl.h>
-#include <patchlevel.h> /* Perl's one, needed since 5.6 */
#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
+#endif
+
#ifndef NETWARE
#if 0
#define DEBUGME /* Debug mode, turns assertions on as well */
if (!mbase) { \
TRACEME(("** allocating mbase of %d bytes", MGROW)); \
New(10003, mbase, MGROW, char); \
- msiz = MGROW; \
+ msiz = (STRLEN)MGROW; \
} \
mptr = mbase; \
if (x) \
#define STORABLE_BIN_WRITE_MINOR 6
#endif /* (PATCHLEVEL <= 6) */
+#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) \
#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
/*
- * Store undef in arrays and hashes without recursing through store().
+ * Store &PL_sv_undef in arrays without recursing through store().
*/
-#define STORE_UNDEF() \
+#define STORE_SV_UNDEF() \
STMT_START { \
cxt->tagnum++; \
- PUTMARK(SX_UNDEF); \
+ PUTMARK(SX_SV_UNDEF); \
} STMT_END
/*
* new retrieve routines.
*/
- cxt->hseen = ((cxt->retrieve_vtbl == sv_old_retrieve) ? newHV() : 0);
+ cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve)
+ ? newHV() : 0);
cxt->aseen = newAV(); /* Where retrieved objects are kept */
cxt->aclass = newAV(); /* Where seen classnames are kept */
#else
SvIV_please(sv);
- if (SvIOK(sv)) {
+ if (SvIOK_notUV(sv)) {
iv = SvIV(sv);
goto integer; /* Share code above */
}
sav = av_fetch(av, i, 0);
if (!sav) {
TRACEME(("(#%d) undef item", i));
- STORE_UNDEF();
+ STORE_SV_UNDEF();
continue;
}
TRACEME(("(#%d) item", i));
= (((hash_flags & SHV_RESTRICTED)
&& SvREADONLY(val))
? SHV_K_LOCKED : 0);
- if (val == &PL_sv_undef)
+ if (val == &PL_sv_placeholder)
flags |= SHV_K_PLACEHOLDER;
keyval = SvPV(key, keylen_tmp);
PUTMARK(flags);
TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval));
} else {
- assert (flags == 0);
+ /* This is a workaround for a bug in 5.8.0
+ that causes the HEK_WASUTF8 flag to be
+ set on an HEK without the hash being
+ marked as having key flags. We just
+ cross our fingers and drop the flag.
+ AMS 20030901 */
+ assert (flags == 0 || flags == SHV_K_WASUTF8);
TRACEME(("(#%d) key '%s'", i, keyval));
}
WLEN(keylen);
/*
* Storing in "random" order (in the order the keys are stored
- * within the the hash). This is the default and will be faster!
+ * within the hash). This is the default and will be faster!
*/
for (i = 0; i < len; i++) {
= (((hash_flags & SHV_RESTRICTED)
&& SvREADONLY(val))
? SHV_K_LOCKED : 0);
- if (val == &PL_sv_undef)
+ if (val == &PL_sv_placeholder)
flags |= SHV_K_PLACEHOLDER;
hek = HeKEY_hek(he);
PUTMARK(flags);
TRACEME(("(#%d) key '%s' flags %x", i, key, flags));
} else {
- assert (flags == 0);
+ /* This is a workaround for a bug in 5.8.0
+ that causes the HEK_WASUTF8 flag to be
+ set on an HEK without the hash being
+ marked as having key flags. We just
+ cross our fingers and drop the flag.
+ AMS 20030901 */
+ assert (flags == 0 || flags == SHV_K_WASUTF8);
TRACEME(("(#%d) key '%s'", i, key));
}
if (flags & SHV_K_ISSV) {
#else
dSP;
I32 len;
- int ret, count, reallen;
+ int count, reallen;
SV *text, *bdeparse;
TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv)));
text = POPs;
len = SvLEN(text);
- reallen = strlen(SvPV(text,PL_na));
+ reallen = strlen(SvPV_nolen(text));
/*
* Empty code references or XS functions are deparsed as
* "(prototype) ;" or ";".
*/
- if (len == 0 || *(SvPV(text,PL_na)+reallen-1) == ';') {
+ if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') {
CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"));
}
*/
PUTMARK(SX_CODE);
+ cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */
TRACEME(("size = %d", len));
- TRACEME(("code = %s", SvPV(text,PL_na)));
+ TRACEME(("code = %s", SvPV_nolen(text)));
/*
* Now store the source code.
*/
- STORE_SCALAR(SvPV(text,PL_na), len);
+ STORE_SCALAR(SvPV_nolen(text), len);
FREETMPS;
LEAVE;
static int store_tied(stcxt_t *cxt, SV *sv)
{
MAGIC *mg;
+ SV *obj = NULL;
int ret = 0;
int svt = SvTYPE(sv);
char mtype = 'P';
* accesses on the retrieved object will indeed call the magic methods...
*/
- if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
+ /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */
+ obj = mg->mg_obj ? mg->mg_obj : newSV(0);
+ if ((ret = store(cxt, obj)))
return ret;
TRACEME(("ok (tied)"));
length -= sizeof (magicstr) - 1;
}
- WRITE(header, length);
+ WRITE( (unsigned char*) header, length);
if (!cxt->netorder) {
TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
* an SX_OBJECT indication, a ref count increment was done.
*/
- sv_upgrade(rv, SVt_RV);
+ if (cname) {
+ /* Do not use sv_upgrade to preserve STASH */
+ SvFLAGS(rv) &= ~SVTYPEMASK;
+ SvFLAGS(rv) |= SVt_RV;
+ } else {
+ sv_upgrade(rv, SVt_RV);
+ }
+
SvRV(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)",
+ if (!SvTYPE(sv)
+ || !(stash = (HV *) SvSTASH (sv))
+ || !Gv_AMG(stash))
+ CROAK(("Cannot restore overloading on %s(0x%"UVxf
+ ") (package %s)",
sv_reftype(sv, FALSE),
PTR2UV(sv),
stash ? HvNAME(stash) : "<unknown>"));
static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname)
{
SV *tv;
- SV *sv;
+ SV *sv, *obj = NULL;
TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
SEEN(tv, cname); /* Will return if rv is null */
sv = retrieve(cxt, 0); /* Retrieve <object> */
- if (!sv)
+ if (!sv) {
return (SV *) 0; /* Failed */
+ }
+ else if (SvTYPE(sv) != SVt_NULL) {
+ obj = sv;
+ }
sv_upgrade(tv, SVt_PVMG);
- sv_magic(tv, sv, 'q', Nullch, 0);
- SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
+ sv_magic(tv, obj, 'q', Nullch, 0);
+
+ if (obj) {
+ /* Undo refcnt inc from sv_magic() */
+ SvREFCNT_dec(obj);
+ }
TRACEME(("ok (retrieve_tied_scalar at 0x%"UVxf")", PTR2UV(tv)));
TRACEME(("retrieve_sv_no"));
+ cxt->tagnum--; /* undo the tagnum increment in retrieve_l?scalar */
SEEN(sv, cname);
return sv;
}
if (flags & SHV_K_PLACEHOLDER) {
SvREFCNT_dec (sv);
- sv = &PL_sv_undef;
+ sv = &PL_sv_placeholder;
store_flags |= HVhek_PLACEHOLD;
}
if (flags & SHV_K_UTF8) {
*/
#ifdef HAS_RESTRICTED_HASHES
- if (hv_store_flags(hv, kbuf, size, sv, 0, flags) == 0)
+ if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0)
return (SV *) 0;
#else
if (!(store_flags & HVhek_PLACEHOLD))
CROAK(("retrieve_code does not work with perl 5.005 or less\n"));
#else
dSP;
- int type, count;
+ int type, count, tagnum;
SV *cv;
- SV *sv, *text, *sub, *errsv;
+ SV *sv, *text, *sub;
TRACEME(("retrieve_code (#%d)", cxt->tagnum));
/*
+ * Insert dummy SV in the aseen array so that we don't screw
+ * up the tag numbers. We would just make the internal
+ * scalar an untagged item in the stream, but
+ * retrieve_scalar() calls SEEN(). So we just increase the
+ * tag number.
+ */
+ tagnum = cxt->tagnum;
+ sv = newSViv(0);
+ SEEN(sv, cname);
+
+ /*
* Retrieve the source of the code reference
* as a small or large scalar
*/
*/
sub = newSVpvn("sub ", 4);
- sv_catpv(sub, SvPV(text, PL_na)); /* XXX no sv_catsv! */
+ sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */
SvREFCNT_dec(text);
/*
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;
}
}
CROAK(("Unexpected return value from $Storable::Eval callback\n"));
cv = POPs;
if (SvTRUE(errsv)) {
- CROAK(("code %s caused an error: %s", SvPV(sub, PL_na), SvPV(errsv, PL_na)));
+ CROAK(("code %s caused an error: %s",
+ SvPV_nolen(sub), SvPV_nolen(errsv)));
}
PUTBACK;
} else {
- cv = eval_pv(SvPV(sub, PL_na), TRUE);
+ cv = eval_pv(SvPV_nolen(sub), TRUE);
}
if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) {
sv = SvRV(cv);
} else {
- CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV(sub, PL_na)));
+ CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub)));
}
SvREFCNT_inc(sv); /* XXX seems to be necessary */
FREETMPS;
LEAVE;
+ /* fix up the dummy entry... */
+ av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
- SEEN(sv, cname);
return sv;
#endif
}
gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV);
#endif
+void
+init_perinterp()
+
int
pstore(f,obj)
OutputStream f
projects / p5sagit/p5-mst-13.2.git / blobdiff