projects / p5sagit/p5-mst-13.2.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw
bump Storage version to 2.20 to distinguish it from the 2.19 that was
[p5sagit/p5-mst-13.2.git] / ext / Storable / Storable.xs
diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index 84d76aa..2741c7d 100644 (file)
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -18,6 +18,9 @@
 #endif
 
 #if !defined(PERL_VERSION) || PERL_VERSION < 8
+#define NEED_load_module
+#define NEED_vload_module
+#define NEED_newCONSTSUB
 #include "ppport.h"             /* handle old perls */
 #endif
 
@@ -148,7 +151,7 @@ typedef double NV;                  /* Older perls lack the NV type */
 
 #define TRACEME(x)                                                                             \
   STMT_START {                                                                                 \
-       if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE)))     \
+       if (SvTRUE(perl_get_sv("Storable::DEBUGME", GV_ADD)))   \
                { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); }             \
   } STMT_END
 #else
@@ -388,7 +391,7 @@ typedef struct stcxt {
   STMT_START {                                                                         \
        SV *self = newSV(sizeof(stcxt_t) - 1);                  \
        SV *my_sv = newRV_noinc(self);                                  \
-       sv_bless(my_sv, gv_stashpv("Storable::Cxt", TRUE));     \
+       sv_bless(my_sv, gv_stashpv("Storable::Cxt", GV_ADD));   \
        cxt = (stcxt_t *)SvPVX(self);                                   \
        Zero(cxt, 1, stcxt_t);                                                  \
        cxt->my_sv = my_sv;                                                             \
@@ -398,7 +401,7 @@ typedef struct stcxt {
 
 #if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
 #define dSTCXT_SV                                                                      \
-       SV *perinterp_sv = perl_get_sv(MY_VERSION, FALSE)
+       SV *perinterp_sv = perl_get_sv(MY_VERSION, 0)
 #else  /* >= perl5.004_68 */
 #define dSTCXT_SV                                                                      \
        SV *perinterp_sv = *hv_fetch(PL_modglobal,              \
@@ -656,6 +659,17 @@ static stcxt_t *Context_ptr = NULL;
        }                                                               \
   } STMT_END
 
+#define MBUF_SAFEPVREAD(x,s,z)                 \
+  STMT_START {                                 \
+       if ((mptr + (s)) <= mend) {             \
+               memcpy(x, mptr, s);             \
+               mptr += s;                      \
+       } else {                                \
+               Safefree(z);                    \
+               return (SV *) 0;                \
+       }                                       \
+  } STMT_END
+
 #define MBUF_PUTC(c)                           \
   STMT_START {                                         \
        if (mptr < mend)                                \
@@ -986,6 +1000,16 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
        }                                                                                       \
   } STMT_END
 
+#define SAFEPVREAD(x,y,z)                                      \
+  STMT_START {                                                 \
+       if (!cxt->fio)                                          \
+               MBUF_SAFEPVREAD(x,y,z);                         \
+       else if (PerlIO_read(cxt->fio, x, y) != y)       {      \
+               Safefree(z);                                    \
+               return (SV *) 0;                                \
+       }                                                       \
+  } STMT_END
+
 /*
  * This macro is used at retrieve time, to remember where object 'y', bearing a
  * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
@@ -1026,7 +1050,7 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
        SV *ref;                                                                \
        HV *stash;                                                              \
        TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \
-       stash = gv_stashpv((p), TRUE);                  \
+       stash = gv_stashpv((p), GV_ADD);                        \
        ref = newRV_noinc(s);                                   \
        (void) sv_bless(ref, stash);                    \
        SvRV_set(ref, NULL);                                            \
@@ -1658,7 +1682,7 @@ static SV *pkg_fetchmeth(
         pTHX_
        HV *cache,
        HV *pkg,
-       char *method)
+       const char *method)
 {
        GV *gv;
        SV *sv;
@@ -1698,7 +1722,7 @@ static void pkg_hide(
         pTHX_
        HV *cache,
        HV *pkg,
-       char *method)
+       const char *method)
 {
        const char *hvname = HvNAME_get(pkg);
        (void) hv_store(cache,
@@ -1714,7 +1738,7 @@ static void pkg_uncache(
         pTHX_
        HV *cache,
        HV *pkg,
-       char *method)
+       const char *method)
 {
        const char *hvname = HvNAME_get(pkg);
        (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD);
@@ -1732,7 +1756,7 @@ static SV *pkg_can(
         pTHX_
        HV *cache,
        HV *pkg,
-       char *method)
+       const char *method)
 {
        SV **svh;
        SV *sv;
@@ -2308,7 +2332,7 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
        if (
                !(cxt->optype & ST_CLONE) && (cxt->canonical == 1 ||
                (cxt->canonical < 0 && (cxt->canonical =
-                       (SvTRUE(perl_get_sv("Storable::canonical", TRUE)) ? 1 : 0))))
+                       (SvTRUE(perl_get_sv("Storable::canonical", GV_ADD)) ? 1 : 0))))
        ) {
                /*
                 * Storing in order, sorted by key.
@@ -2329,7 +2353,11 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
 #else
                        HE *he = hv_iternext(hv);
 #endif
-                       SV *key = hv_iterkeysv(he);
+                       SV *key;
+
+                       if (!he)
+                               CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, len, i));
+                       key = hv_iterkeysv(he);
                        av_store(av, AvFILLp(av)+1, key);       /* av_push(), really */
                }
                        
@@ -2591,7 +2619,7 @@ static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
        if (
                cxt->deparse == 0 ||
                (cxt->deparse < 0 && !(cxt->deparse =
-                       SvTRUE(perl_get_sv("Storable::Deparse", TRUE)) ? 1 : 0))
+                       SvTRUE(perl_get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0))
        ) {
                return store_other(aTHX_ cxt, (SV*)cv);
        }
@@ -2602,6 +2630,7 @@ static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
         */
        /* Ownership of both SVs is passed to load_module, which frees them. */
        load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61));
+        SPAGAIN;
 
        ENTER;
        SAVETMPS;
@@ -3024,7 +3053,7 @@ static int store_hook(
                   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)))
+               if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv)))
                        goto sv_seen;           /* Avoid moving code too far to the right */
 #else
                if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
@@ -3057,7 +3086,7 @@ static int store_hook(
                        return ret;
 
 #ifdef USE_PTR_TABLE
-               fake_tag = ptr_table_fetch(cxt->pseen, xsv);
+               fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv);
                if (!sv)
                        CROAK(("Could not serialize item #%d from hook in %s", i, classname));
 #else
@@ -3368,7 +3397,7 @@ static int store_other(pTHX_ stcxt_t *cxt, SV *sv)
        if (
                cxt->forgive_me == 0 ||
                (cxt->forgive_me < 0 && !(cxt->forgive_me =
-                       SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0))
+                       SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
        )
                CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
 
@@ -3405,7 +3434,9 @@ static int sv_type(pTHX_ SV *sv)
 {
        switch (SvTYPE(sv)) {
        case SVt_NULL:
+#if PERL_VERSION <= 10
        case SVt_IV:
+#endif
        case SVt_NV:
                /*
                 * No need to check for ROK, that can't be set here since there
@@ -3413,7 +3444,11 @@ static int sv_type(pTHX_ SV *sv)
                 */
                return svis_SCALAR;
        case SVt_PV:
+#if PERL_VERSION <= 10
        case SVt_RV:
+#else
+       case SVt_IV:
+#endif
        case SVt_PVIV:
        case SVt_PVNV:
                /*
@@ -3431,7 +3466,9 @@ static int sv_type(pTHX_ SV *sv)
                if (SvRMAGICAL(sv) && (mg_find(sv, 'p')))
                        return svis_TIED_ITEM;
                /* FALL THROUGH */
+#if PERL_VERSION < 9
        case SVt_PVBM:
+#endif
                if (SvRMAGICAL(sv) && (mg_find(sv, 'q')))
                        return svis_TIED;
                return SvROK(sv) ? svis_REF : svis_SCALAR;
@@ -3445,6 +3482,9 @@ static int sv_type(pTHX_ SV *sv)
                return svis_HASH;
        case SVt_PVCV:
                return svis_CODE;
+#if PERL_VERSION > 8
+       /* case SVt_BIND: */
+#endif
        default:
                break;
        }
@@ -3487,7 +3527,7 @@ static int store(pTHX_ stcxt_t *cxt, SV *sv)
         */
 
 #ifdef USE_PTR_TABLE
-       svh = ptr_table_fetch(pseen, sv);
+       svh = (SV **)ptr_table_fetch(pseen, sv);
 #else
        svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
 #endif
@@ -3649,7 +3689,7 @@ static int magic_write(pTHX_ stcxt_t *cxt)
         length = sizeof (network_file_header);
     } else {
 #ifdef USE_56_INTERWORK_KLUDGE
-        if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) {
+        if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) {
             header = file_header_56;
             length = sizeof (file_header_56);
         } else
@@ -3959,6 +3999,7 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
        SV *sv;
        char buf[LG_BLESS + 1];         /* Avoid malloc() if possible */
        char *classname = buf;
+       char *malloced_classname = NULL;
 
        TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
        ASSERT(!cname, ("no bless-into class given here, got %s", cname));
@@ -3975,8 +4016,9 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
                RLEN(len);
                TRACEME(("** allocating %d bytes for class name", len+1));
                New(10003, classname, len+1, char);
+               malloced_classname = classname;
        }
-       READ(classname, len);
+       SAFEPVREAD(classname, len, malloced_classname);
        classname[len] = '\0';          /* Mark string end */
 
        /*
@@ -3985,16 +4027,18 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
 
        TRACEME(("new class name \"%s\" will bear ID = %d", classname, cxt->classnum));
 
-       if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len)))
+       if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) {
+               Safefree(malloced_classname);
                return (SV *) 0;
+       }
 
        /*
         * Retrieve object and bless it.
         */
 
        sv = retrieve(aTHX_ cxt, classname);    /* First SV which is SEEN will be blessed */
-       if (classname != buf)
-               Safefree(classname);
+       if (malloced_classname)
+               Safefree(malloced_classname);
 
        return sv;
 }
@@ -4146,6 +4190,7 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
                 * on the stack.  Just like retrieve_blessed(), we limit the name to
                 * LG_BLESS bytes.  This is an arbitrary decision.
                 */
+               char *malloced_classname = NULL;
 
                if (flags & SHF_LARGE_CLASSLEN)
                        RLEN(len);
@@ -4155,17 +4200,20 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
                if (len > LG_BLESS) {
                        TRACEME(("** allocating %d bytes for class name", len+1));
                        New(10003, classname, len+1, char);
+                       malloced_classname = classname;
                }
 
-               READ(classname, len);
+               SAFEPVREAD(classname, len, malloced_classname);
                classname[len] = '\0';          /* Mark string end */
 
                /*
                 * Record new classname.
                 */
 
-               if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len)))
+               if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) {
+                       Safefree(malloced_classname);
                        return (SV *) 0;
+               }
        }
 
        TRACEME(("class name: %s", classname));
@@ -4402,7 +4450,7 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
         * into the existing design.  -- RAM, 17/02/2001
         */
 
-       sv_magic(sv, rv, mtype, Nullch, 0);
+       sv_magic(sv, rv, mtype, (char *)NULL, 0);
        SvREFCNT_dec(rv);                       /* Undo refcnt inc from sv_magic() */
 
        return sv;
@@ -4455,7 +4503,7 @@ static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname)
 
        if (cname) {
                /* No need to do anything, as rv will already be PVMG.  */
-               assert (SvTYPE(rv) >= SVt_RV);
+               assert (SvTYPE(rv) == SVt_RV || SvTYPE(rv) >= SVt_PV);
        } else {
                sv_upgrade(rv, SVt_RV);
        }
@@ -4519,7 +4567,7 @@ static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname)
         * WARNING: breaks RV encapsulation.
         */
 
-       sv_upgrade(rv, SVt_RV);
+       SvUPGRADE(rv, SVt_RV);
        SvRV_set(rv, sv);                               /* $rv = \$sv */
        SvROK_on(rv);
 
@@ -4599,7 +4647,7 @@ static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname)
 
        sv_upgrade(tv, SVt_PVAV);
        AvREAL_off((AV *)tv);
-       sv_magic(tv, sv, 'P', Nullch, 0);
+       sv_magic(tv, sv, 'P', (char *)NULL, 0);
        SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
 
        TRACEME(("ok (retrieve_tied_array at 0x%"UVxf")", PTR2UV(tv)));
@@ -4627,7 +4675,7 @@ static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname)
                return (SV *) 0;                /* Failed */
 
        sv_upgrade(tv, SVt_PVHV);
-       sv_magic(tv, sv, 'P', Nullch, 0);
+       sv_magic(tv, sv, 'P', (char *)NULL, 0);
        SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
 
        TRACEME(("ok (retrieve_tied_hash at 0x%"UVxf")", PTR2UV(tv)));
@@ -4659,7 +4707,7 @@ static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname)
        }
 
        sv_upgrade(tv, SVt_PVMG);
-       sv_magic(tv, obj, 'q', Nullch, 0);
+       sv_magic(tv, obj, 'q', (char *)NULL, 0);
 
        if (obj) {
                /* Undo refcnt inc from sv_magic() */
@@ -4726,7 +4774,7 @@ static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname)
        RLEN(idx);                                      /* Retrieve <idx> */
 
        sv_upgrade(tv, SVt_PVMG);
-       sv_magic(tv, sv, 'p', Nullch, idx);
+       sv_magic(tv, sv, 'p', (char *)NULL, idx);
        SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
 
        return tv;
@@ -4865,7 +4913,7 @@ static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname)
 #else
         if (cxt->use_bytes < 0)
             cxt->use_bytes
-                = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
+                = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD))
                    ? 1 : 0);
         if (cxt->use_bytes == 0)
             UTF8_CROAK();
@@ -4894,7 +4942,7 @@ static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname)
 #else
         if (cxt->use_bytes < 0)
             cxt->use_bytes
-                = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
+                = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD))
                    ? 1 : 0);
         if (cxt->use_bytes == 0)
             UTF8_CROAK();
@@ -5225,7 +5273,7 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname)
     if (hash_flags & SHV_RESTRICTED) {
         if (cxt->derestrict < 0)
             cxt->derestrict
-                = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", TRUE))
+                = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", GV_ADD))
                    ? 1 : 0);
         if (cxt->derestrict == 0)
             RESTRICTED_HASH_CROAK();
@@ -5294,7 +5342,7 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname)
 #else
                 if (cxt->use_bytes < 0)
                     cxt->use_bytes
-                        = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
+                        = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD))
                            ? 1 : 0);
                 if (cxt->use_bytes == 0)
                     UTF8_CROAK();
@@ -5395,14 +5443,14 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname)
         */
 
        if (cxt->eval == NULL) {
-               cxt->eval = perl_get_sv("Storable::Eval", TRUE);
+               cxt->eval = perl_get_sv("Storable::Eval", GV_ADD);
                SvREFCNT_inc(cxt->eval);
        }
        if (!SvTRUE(cxt->eval)) {
                if (
                        cxt->forgive_me == 0 ||
                        (cxt->forgive_me < 0 && !(cxt->forgive_me =
-                               SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0))
+                               SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
                ) {
                        CROAK(("Can't eval, please set $Storable::Eval to a true value"));
                } else {
@@ -5417,7 +5465,7 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname)
        SAVETMPS;
 
        if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) {
-               SV* errsv = get_sv("@", TRUE);
+               SV* errsv = get_sv("@", GV_ADD);
                sv_setpvn(errsv, "", 0);        /* clear $@ */
                PUSHMARK(sp);
                XPUSHs(sv_2mortal(newSVsv(sub)));
@@ -5729,7 +5777,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt)
             if (cxt->accept_future_minor < 0)
                 cxt->accept_future_minor
                     = (SvTRUE(perl_get_sv("Storable::accept_future_minor",
-                                          TRUE))
+                                          GV_ADD))
                        ? 1 : 0);
             if (cxt->accept_future_minor == 1)
                 croak_now = 0;  /* Don't croak yet.  */
@@ -5766,7 +5814,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt)
 #ifdef USE_56_INTERWORK_KLUDGE
     /* No point in caching this in the context as we only need it once per
        retrieve, and we need to recheck it each read.  */
-    if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) {
+    if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) {
         if ((c != (sizeof (byteorderstr_56) - 1))
             || memNE(buf, byteorderstr_56, c))
             CROAK(("Byte order is not compatible"));
@@ -5900,7 +5948,7 @@ static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname)
             if (cxt->accept_future_minor < 0)
                 cxt->accept_future_minor
                     = (SvTRUE(perl_get_sv("Storable::accept_future_minor",
-                                          TRUE))
+                                          GV_ADD))
                        ? 1 : 0);
             if (cxt->accept_future_minor == 1) {
                 CROAK(("Storable binary image v%d.%d contains data of type %d. "
@@ -6250,7 +6298,11 @@ static SV *dclone(pTHX_ SV *sv)
         * Tied elements seem to need special handling.
         */
 
-       if (SvTYPE(sv) == SVt_PVLV && SvRMAGICAL(sv) && mg_find(sv, 'p')) {
+       if ((SvTYPE(sv) == SVt_PVLV
+#if PERL_VERSION < 8
+            || SvTYPE(sv) == SVt_PVMG
+#endif
+            ) && SvRMAGICAL(sv) && mg_find(sv, 'p')) {
                mg_get(sv);
        }
 
@@ -6338,7 +6390,7 @@ PROTOTYPES: ENABLE
 
 BOOT:
 {
-    HV *stash = gv_stashpvn("Storable", 8, TRUE);
+    HV *stash = gv_stashpvn("Storable", 8, GV_ADD);
     newCONSTSUB(stash, "BIN_MAJOR", newSViv(STORABLE_BIN_MAJOR));
     newCONSTSUB(stash, "BIN_MINOR", newSViv(STORABLE_BIN_MINOR));
     newCONSTSUB(stash, "BIN_WRITE_MINOR", newSViv(STORABLE_BIN_WRITE_MINOR));
Unnamed repository; edit this file to name it for gitweb.