diff options
| -rw-r--r-- | embed.h | 4 | ||||
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | gv.c | 8 | ||||
| -rw-r--r-- | gv.h | 13 | ||||
| -rw-r--r-- | op.c | 18 | ||||
| -rw-r--r-- | pp_sys.c | 5 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | sv.c | 80 |
8 files changed, 129 insertions, 1 deletions
@@ -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 @@ -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 @@ -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; } @@ -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 @@ -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)) { @@ -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; @@ -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 @@ -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); |