Try to make PPPort.pm 5.005-friendlier (see [perl #21339]).

[p5sagit/p5-mst-13.2.git] / ext / Storable / Storable.xs

diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index 48d05f9..fe6ee11 100644 (file)
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -10,9 +10,15 @@
 
 #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 */
@@ -2424,14 +2430,14 @@ static int store_code(stcxt_t *cxt, CV *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"));
        }
 
@@ -2441,13 +2447,13 @@ static int store_code(stcxt_t *cxt, CV *cv)
 
        PUTMARK(SX_CODE);
        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;
@@ -3366,7 +3372,7 @@ static int magic_write(stcxt_t *cxt)
         length -= sizeof (magicstr) - 1;
     }        
 
-    WRITE(header, length);
+    WRITE( (unsigned char*) header, length);
 
     if (!cxt->netorder) {
        TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
@@ -4125,7 +4131,14 @@ static SV *retrieve_ref(stcxt_t *cxt, char *cname)
         * an SX_OBJECT indication, a ref count increment was done.
         */
 
-       sv_upgrade(rv, SVt_RV);
+       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);
 
@@ -4962,7 +4975,7 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname)
         */
 
        sub = newSVpvn("sub ", 4);
-       sv_catpv(sub, SvPV(text, PL_na)); //XXX no sv_catsv!
+       sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */
        SvREFCNT_dec(text);
 
        /*
@@ -5001,16 +5014,17 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname)
                        CROAK(("Unexpected return value from $Storable::Eval callback\n"));
                cv = POPs;
                if (SvTRUE(errsv)) {
-                       CROAK(("code %s caused an error: %s", SvPV(sub, PL_na), SvPV(errsv, PL_na)));
+                       CROAK(("code %s caused an error: %s",
+                               SvPV_nolen(sub), SvPV_nolen(errsv)));
                }
                PUTBACK;
        } else {
-               cv = eval_pv(SvPV(sub, PL_na), TRUE);
+               cv = eval_pv(SvPV_nolen(sub), TRUE);
        }
        if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) {
            sv = SvRV(cv);
        } else {
-           CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV(sub, PL_na)));
+           CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub)));
        }
 
        SvREFCNT_inc(sv); /* XXX seems to be necessary */
@@ -5348,7 +5362,7 @@ static SV *magic_check(stcxt_t *cxt)
 
     /* sizeof(char *) */
     if ((int) *current != sizeof(char *))
-        CROAK(("Pointer integer size is not compatible"));
+        CROAK(("Pointer size is not compatible"));
 
     if (use_NV_size) {
         /* sizeof(NV) */
@@ -5642,7 +5656,22 @@ static SV *do_retrieve(
 
        if (!sv) {
                TRACEME(("retrieve ERROR"));
+#if (PATCHLEVEL <= 4) 
+               /* perl 5.00405 seems to screw up at this point with an
+                  'attempt to modify a read only value' error reported in the
+                  eval { $self = pretrieve(*FILE) } in _retrieve.
+                  I can't see what the cause of this error is, but I suspect a
+                  bug in 5.004, as it seems to be capable of issuing spurious
+                  errors or core dumping with matches on $@. I'm not going to
+                  spend time on what could be a fruitless search for the cause,
+                  so here's a bodge. If you're running 5.004 and don't like
+                  this inefficiency, either upgrade to a newer perl, or you are
+                  welcome to find the problem and send in a patch.
+                */
+               return newSV(0);
+#else
                return &PL_sv_undef;            /* Something went wrong, return undef */
+#endif
        }
 
        TRACEME(("retrieve got %s(0x%"UVxf")",