X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=da50eac23542913a8b2e135caf2239df97a1f24b;hb=895fe8448c39ec9ce61fb5a2b7f671d3d15dcb46;hp=bbe8d47a5b6ff96379a0da7e4ed299c5571ee1b4;hpb=497b47a829dd93323de2c7f4f6815ab9f23d6ada;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index bbe8d47..da50eac 100644 --- a/gv.c +++ b/gv.c @@ -46,9 +46,9 @@ Perl_gv_IOadd(pTHX_ register GV *gv) if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) Perl_croak(aTHX_ "Bad symbol for filehandle"); if (!GvIOp(gv)) { -#ifdef GV_SHARED_CHECK - if (GvSHARED(gv)) { - Perl_croak(aTHX_ "Bad symbol for filehandle (GV is shared)"); +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE(gv)) { + Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)"); } #endif GvIOp(gv) = newIO(); @@ -128,13 +128,13 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) CvGV(GvCV(gv)) = gv; CvFILE_set_from_cop(GvCV(gv), PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; -#ifdef USE_THREADS +#ifdef USE_5005THREADS CvOWNER(GvCV(gv)) = 0; if (!CvMUTEXP(GvCV(gv))) { New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(GvCV(gv))); } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (proto) { sv_setpv((SV*)GvCV(gv), proto); Safefree(proto); @@ -439,7 +439,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); -#ifndef USE_THREADS +#ifndef USE_5005THREADS if (CvXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here * only to have the XSUB do another lookup for $AUTOLOAD @@ -463,14 +463,14 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); ENTER; -#ifdef USE_THREADS +#ifdef USE_5005THREADS sv_lock((SV *)varstash); #endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); -#ifdef USE_THREADS +#ifdef USE_5005THREADS sv_lock(varsv); #endif sv_setpv(varsv, HvNAME(stash)); @@ -656,7 +656,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) strEQ(name, "ARGVOUT"))) global = TRUE; } - else if (*name == '_' && !name[1]) + else if (*name == '_' && (!name[1] || strEQ(name,"__ANON__"))) global = TRUE; if (global) @@ -814,20 +814,16 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) break; case '&': - if (len > 1) - break; - PL_sawampersand = TRUE; - goto ro_magicalize; - case '`': - if (len > 1) - break; - PL_sawampersand = TRUE; - goto ro_magicalize; - case '\'': - if (len > 1) - break; + if ( + len > 1 || + sv_type == SVt_PVAV || + sv_type == SVt_PVHV || + sv_type == SVt_PVCV || + sv_type == SVt_PVFM || + sv_type == SVt_PVIO + ) { break; } PL_sawampersand = TRUE; goto ro_magicalize; @@ -897,7 +893,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '\011': /* $^I, NOT \t in EBCDIC */ case '\016': /* $^N */ case '\020': /* $^P */ - case '\024': /* $^T */ if (len > 1) break; goto magicalize; @@ -914,6 +909,13 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (len > 1) break; goto ro_magicalize; + case '\024': /* $^T, ${^TAINT} */ + if (len == 1) + goto magicalize; + else if (strEQ(name, "\024AINT")) + goto ro_magicalize; + else + break; case '\027': /* $^W & $^WARNING_BITS */ if (len > 1 && strNE(name, "\027ARNING_BITS") && strNE(name, "\027IDE_SYSTEM_CALLS")) @@ -938,6 +940,17 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '7': case '8': case '9': + /* ensures variable is only digits */ + /* ${"1foo"} fails this test (and is thus writeable) */ + /* added by japhy, but borrowed from is_gv_magical */ + + if (len > 1) { + const char *end = name + len; + while (--end > name) { + if (!isDIGIT(*end)) return gv; + } + } + ro_magicalize: SvREADONLY_on(GvSV(gv)); magicalize: @@ -1361,15 +1374,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0; #ifdef DEBUGGING int fl=0; - HV* stash=NULL; #endif + HV* stash=NULL; if (!(AMGf_noleft & flags) && SvAMAGIC(left) - && (mg = mg_find((SV*)( -#ifdef DEGUGGING - stash= -#endif - SvSTASH(SvRV(left))), - PERL_MAGIC_overload_table)) + && (stash = SvSTASH(SvRV(left))) + && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table : (CV **) NULL)) @@ -1486,12 +1495,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) - && (mg = mg_find((SV*)( -#ifdef DEBUGGING - stash= -#endif - SvSTASH(SvRV(right))), - PERL_MAGIC_overload_table)) + && (stash = SvSTASH(SvRV(right))) + && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table : (CV **) NULL)) @@ -1590,7 +1595,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", flags & AMGf_unary? " for argument" : "", - HvNAME(stash), + stash ? HvNAME(stash) : "null", fl? ",\n\tassignment variant used": "") ); } #endif @@ -1785,11 +1790,14 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) case '\016': /* $^N */ case '\020': /* $^P */ case '\023': /* $^S */ - case '\024': /* $^T */ case '\026': /* $^V */ if (len == 1) goto yes; break; + case '\024': /* $^T, ${^TAINT} */ + if (len == 1 || strEQ(name, "\024AINT")) + goto yes; + break; case '1': case '2': case '3':