[patch] GvSHARED

Message-ID: <Pine.LNX.4.21.0102101047320.15298-100000@mako.covalent.net>

p4raw-id: //depot/perl@8760

diff --git a/embed.h b/embed.h
index 9b76260..6d2eea6 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -846,6 +846,7 @@
 #define gp_dup                 Perl_gp_dup
 #define mg_dup                 Perl_mg_dup
 #define sv_dup                 Perl_sv_dup
+#define gv_share               S_gv_share
 #if defined(HAVE_INTERP_INTERN)
 #define sys_intern_dup         Perl_sys_intern_dup
 #endif
@@ -2320,6 +2321,7 @@
 #define gp_dup(a)              Perl_gp_dup(aTHX_ a)
 #define mg_dup(a)              Perl_mg_dup(aTHX_ a)
 #define sv_dup(a)              Perl_sv_dup(aTHX_ a)
+#define gv_share(a)            S_gv_share(aTHX_ a)
 #if defined(HAVE_INTERP_INTERN)
 #define sys_intern_dup(a,b)    Perl_sys_intern_dup(aTHX_ a,b)
 #endif
@@ -4553,6 +4555,8 @@
 #define mg_dup                 Perl_mg_dup
 #define Perl_sv_dup            CPerlObj::Perl_sv_dup
 #define sv_dup                 Perl_sv_dup
+#define S_gv_share             CPerlObj::S_gv_share
+#define gv_share               S_gv_share
 #if defined(HAVE_INTERP_INTERN)
 #define Perl_sys_intern_dup    CPerlObj::Perl_sys_intern_dup
 #define sys_intern_dup         Perl_sys_intern_dup

diff --git a/embed.pl b/embed.pl
index e7810fc..e350a45 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2205,6 +2205,7 @@ Ap        |DIR*   |dirp_dup       |DIR* dp
 Ap     |GP*    |gp_dup         |GP* gp
 Ap     |MAGIC* |mg_dup         |MAGIC* mg
 Ap     |SV*    |sv_dup         |SV* sstr
+s      |SV*    |gv_share       |SV *sv
 #if defined(HAVE_INTERP_INTERN)
 Ap     |void   |sys_intern_dup |struct interp_intern* src \
                                |struct interp_intern* dst

diff --git a/gv.c b/gv.c
index c73d503..1539ddd 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -45,8 +45,14 @@ Perl_gv_IOadd(pTHX_ register GV *gv)
 {
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
        Perl_croak(aTHX_ "Bad symbol for filehandle");
-    if (!GvIOp(gv))
+    if (!GvIOp(gv)) {
+#ifdef GV_SHARED_CHECK
+        if (GvSHARED(gv)) {
+            Perl_croak(aTHX_ "Bad symbol for filehandle (GV is shared)");
+        }
+#endif
        GvIOp(gv) = newIO();
+    }
     return gv;
 }
 

diff --git a/gv.h b/gv.h
index 07a04b6..01764e3 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -131,6 +131,19 @@ HV *GvHVn();
 #define GvIN_PAD_on(gv)                (GvFLAGS(gv) |= GVf_IN_PAD)
 #define GvIN_PAD_off(gv)       (GvFLAGS(gv) &= ~GVf_IN_PAD)
 
+/* XXX: all GvFLAGS options are used, borrowing GvGPFLAGS for the moment */
+
+#define GVf_SHARED           0x0001
+#define GvSHARED(gv)         (GvGP(gv) && (GvGPFLAGS(gv) & GVf_SHARED))
+#define GvSHARED_on(gv)      (GvGPFLAGS(gv) |= GVf_SHARED)
+#define GvSHARED_off(gv)     (GvGPFLAGS(gv) &= ~GVf_SHARED)
+
+#ifdef USE_ITHREADS
+#define GV_SHARED_CHECK
+#else
+#undef  GV_SHARED_CHECK
+#endif
+
 #define Nullgv Null(GV*)
 
 #define DM_UID   0x003

diff --git a/op.c b/op.c
index 379d7e9..224cd61 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4548,6 +4548,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 
     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
 
+#ifdef GV_SHARED_CHECK
+    if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
+        Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
+    }
+#endif
+
     if (!block || !ps || *ps || attrs)
        const_sv = Nullsv;
     else
@@ -4555,6 +4561,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 
     if (cv) {
         bool exists = CvROOT(cv) || CvXSUB(cv);
+
+#ifdef GV_SHARED_CHECK
+        if (exists && GvSHARED(gv)) {
+            Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
+        }
+#endif
+
         /* if the subroutine doesn't exist and wasn't pre-declared
          * with a prototype, assume it will be AUTOLOADed,
          * skipping the prototype check
@@ -5006,6 +5019,11 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     else
        name = "STDOUT";
     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
+#ifdef GV_SHARED_CHECK
+    if (GvSHARED(gv)) {
+        Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
+    }
+#endif
     GvMULTI_on(gv);
     if ((cv = GvFORM(gv))) {
        if (ckWARN(WARN_REDEFINE)) {

diff --git a/pp_sys.c b/pp_sys.c
index 283dbc1..2f45855 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -757,6 +757,11 @@ PP(pp_tie)
            methname = "TIEARRAY";
            break;
        case SVt_PVGV:
+#ifdef GV_SHARED_CHECK
+           if (GvSHARED((GV*)varsv)) {
+                Perl_croak(aTHX_ "Attempt to tie shared GV");
+           }
+#endif
            methname = "TIEHANDLE";
            how = 'q';
            break;

diff --git a/proto.h b/proto.h
index cd4bc9a..807fab1 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -947,6 +947,7 @@ PERL_CALLCONV DIR*  Perl_dirp_dup(pTHX_ DIR* dp);
 PERL_CALLCONV GP*      Perl_gp_dup(pTHX_ GP* gp);
 PERL_CALLCONV MAGIC*   Perl_mg_dup(pTHX_ MAGIC* mg);
 PERL_CALLCONV SV*      Perl_sv_dup(pTHX_ SV* sstr);
+STATIC SV*     S_gv_share(pTHX_ SV *sv);
 #if defined(HAVE_INTERP_INTERN)
 PERL_CALLCONV void     Perl_sys_intern_dup(pTHX_ struct interp_intern* src, struct interp_intern* dst);
 #endif

diff --git a/sv.c b/sv.c
index 9fc3386..486b104 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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);
@@ -7749,6 +7762,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 +7949,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);