Integrate mainline

[p5sagit/p5-mst-13.2.git] / sv.c

diff --git a/sv.c b/sv.c
index 9fc3386..1098680 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3048,7 +3048,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv)
     if (SvPOK(sv)) {
         char *c;
         char *e;
-        bool has_utf = FALSE;
+
         if (!sv_utf8_downgrade(sv, TRUE))
            return FALSE;
 
@@ -3218,6 +3218,13 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                     && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
                Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
                      GvNAME(dstr));
+
+#ifdef GV_SHARED_CHECK
+                if (GvSHARED((GV*)dstr)) {
+                    Perl_croak(aTHX_ PL_no_modify);
+                }
+#endif
+
            (void)SvOK_off(dstr);
            GvINTRO_off(dstr);          /* one-shot flag */
            gp_free((GV*)dstr);
@@ -3258,6 +3265,12 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                SV *dref = 0;
                int intro = GvINTRO(dstr);
 
+#ifdef GV_SHARED_CHECK
+                if (GvSHARED((GV*)dstr)) {
+                    Perl_croak(aTHX_ PL_no_modify);
+                }
+#endif
+
                if (intro) {
                    GP *gp;
                    gp_free((GV*)dstr);
@@ -3312,7 +3325,6 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                            if (!GvCVGEN((GV*)dstr) &&
                                (CvROOT(cv) || CvXSUB(cv)))
                            {
-                               SV *const_sv;
                                /* ahem, death to those who redefine
                                 * active sort subs */
                                if (PL_curstackinfo->si_type == PERLSI_SORT &&
@@ -3479,8 +3491,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
        if (sflags & SVf_IOK)
            (void)SvIOK_only(dstr);
        else {
-           SvOK_off(dstr);
-           SvIOKp_on(dstr);
+           (void)SvOK_off(dstr);
+           (void)SvIOKp_on(dstr);
        }
        /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
        if (sflags & SVf_IVisUV)
@@ -3498,7 +3510,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
        if (sflags & SVf_NOK)
            (void)SvNOK_only(dstr);
        else {
-           SvOK_off(dstr);
+           (void)SvOK_off(dstr);
            SvNOKp_on(dstr);
        }
        SvNVX(dstr) = SvNVX(sstr);
@@ -3944,11 +3956,12 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     }
     mg->mg_type = how;
     mg->mg_len = namlen;
-    if (name)
+    if (name) {
        if (namlen >= 0)
            mg->mg_ptr = savepvn(name, namlen);
        else if (namlen == HEf_SVKEY)
            mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+    }
 
     switch (how) {
     case 0:
@@ -4090,11 +4103,12 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type)
            *mgp = mg->mg_moremagic;
            if (vtbl && vtbl->svt_free)
                CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
-           if (mg->mg_ptr && mg->mg_type != 'g')
+           if (mg->mg_ptr && mg->mg_type != 'g') {
                if (mg->mg_len >= 0)
                    Safefree(mg->mg_ptr);
                else if (mg->mg_len == HEf_SVKEY)
                    SvREFCNT_dec((SV*)mg->mg_ptr);
+            }
            if (mg->mg_flags & MGf_REFCOUNTED)
                SvREFCNT_dec(mg->mg_obj);
            Safefree(mg);
@@ -6906,7 +6920,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            q++;
            if (vectorize)
                goto unknown;
-           if (vectorarg = asterisk) {
+           if ((vectorarg = asterisk)) {
                evix = ewix;
                ewix = 0;
                asterisk = FALSE;
@@ -7749,6 +7763,61 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
 char *PL_watch_pvx;
 #endif
 
+STATIC SV *
+S_gv_share(pTHX_ SV *sstr)
+{
+    GV *gv = (GV*)sstr;
+    SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
+
+    if (GvIO(gv) || GvFORM(gv)) {
+        GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
+    }
+    else if (!GvCV(gv)) {
+        GvCV(gv) = (CV*)sv;
+    }
+    else {
+        /* CvPADLISTs cannot be shared */
+        if (!CvXSUB(GvCV(gv))) {
+            GvSHARED_off(gv);
+        }
+    }
+
+    if (!GvSHARED(gv)) {
+#if 0
+        PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
+                      HvNAME(GvSTASH(gv)), GvNAME(gv));
+#endif
+        return Nullsv;
+    }
+
+    /* 
+     * write attempts will die with
+     * "Modification of a read-only value attempted"
+     */
+    if (!GvSV(gv)) {
+        GvSV(gv) = sv;
+    }
+    else {
+        SvREADONLY_on(GvSV(gv));
+    }
+
+    if (!GvAV(gv)) {
+        GvAV(gv) = (AV*)sv;
+    }
+    else {
+        SvREADONLY_on(GvAV(gv));
+    }
+
+    if (!GvHV(gv)) {
+        GvHV(gv) = (HV*)sv;
+    }
+    else {
+        SvREADONLY_on(GvAV(gv));
+    }
+
+    return sstr; /* he_dup() will SvREFCNT_inc() */
+}
+
 SV *
 Perl_sv_dup(pTHX_ SV *sstr)
 {
@@ -7881,6 +7950,18 @@ Perl_sv_dup(pTHX_ SV *sstr)
        LvTYPE(dstr)    = LvTYPE(sstr);
        break;
     case SVt_PVGV:
+       if (GvSHARED((GV*)sstr)) {
+            SV *share;
+            if ((share = gv_share(sstr))) {
+                del_SV(dstr);
+                dstr = share;
+#if 0
+                PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
+                              HvNAME(GvSTASH(share)), GvNAME(share));
+#endif
+                break;
+            }
+       }
        SvANY(dstr)     = new_XPVGV();
        SvCUR(dstr)     = SvCUR(sstr);
        SvLEN(dstr)     = SvLEN(sstr);