X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=a67b36f786797cebd9a6e203dde7d85147d04ca0;hb=7ac4cfc1a831c8fe810302b2ae5c11520fbd6a1a;hp=c0f0d93f80b63e7e9341fe041a7da44ac4516a7d;hpb=a080fe3d0f499f7661182f9f8b2f5f534ae785f2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index c0f0d93..a67b36f 100644 --- a/gv.c +++ b/gv.c @@ -1,6 +1,6 @@ /* gv.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -16,6 +16,10 @@ * laughed Pippin. */ +/* +=head1 GV Functions +*/ + #include "EXTERN.h" #define PERL_IN_GV_C #include "perl.h" @@ -46,9 +50,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(); @@ -72,6 +76,7 @@ Perl_gv_fetchfile(pTHX_ const char *name) tmpbuf = smallbuf; else New(603, tmpbuf, tmplen + 1, char); + /* This is where the debugger's %{"::_<$filename"} hash is created */ tmpbuf[0] = '_'; tmpbuf[1] = '<'; strcpy(tmpbuf + 2, name); @@ -126,15 +131,15 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) PL_sub_generation++; CvGV(GvCV(gv)) = gv; - CvFILE(GvCV(gv)) = CopFILE(PL_curcop); + 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); @@ -195,8 +200,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) return 0; } - if (!HvNAME(stash)) - Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); if ((level > 100) || (level < -100)) Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", name, HvNAME(stash)); @@ -413,8 +416,8 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { - static char autoload[] = "AUTOLOAD"; - static STRLEN autolen = 8; + char autoload[] = "AUTOLOAD"; + STRLEN autolen = sizeof(autoload)-1; GV* gv; CV* cv; HV* varstash; @@ -441,7 +444,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 @@ -449,7 +452,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) * pass along the same data via some unused fields in the CV */ CvSTASH(cv) = stash; - SvPVX(cv) = (char *)name; /* cast to loose constness warning */ + SvPVX(cv) = (char *)name; /* cast to lose constness warning */ SvCUR(cv) = len; return gv; } @@ -465,14 +468,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)); @@ -495,7 +498,8 @@ S_require_errno(pTHX_ GV *gv) PUTBACK; ENTER; save_scalar(gv); /* keep the value of $! */ - require_pv("Errno.pm"); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvn("Errno",5), Nullsv); LEAVE; SPAGAIN; stash = gv_stashpvn("Errno",5,FALSE); @@ -658,7 +662,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) @@ -816,20 +820,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; @@ -893,12 +893,11 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ - case '\005': /* $^E */ case '\006': /* $^F */ case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ + case '\016': /* $^N */ case '\020': /* $^P */ - case '\024': /* $^T */ if (len > 1) break; goto magicalize; @@ -907,6 +906,11 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) break; sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); goto magicalize; + case '\005': /* $^E && $^ENCODING */ + if (len > 1 && strNE(name, "\005NCODING")) + break; + goto magicalize; + case '\017': /* $^O & $^OPEN */ if (len > 1 && strNE(name, "\017PEN")) break; @@ -915,6 +919,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")) @@ -939,6 +950,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: @@ -1077,7 +1099,7 @@ Perl_gv_check(pTHX_ HV *stash) for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && - (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv)) + (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv))) { if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ @@ -1280,7 +1302,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { /* GvSV contains the name of the method. */ - GV *ngv; + GV *ngv = Nullgv; DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) ); @@ -1358,19 +1380,26 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) CV *cv=NULL; CV **cvp=NULL, **ocvp=NULL; AMT *amtp=NULL, *oamtp=NULL; - int fl=0, off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0; + int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0; int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0; +#ifdef DEBUGGING + int fl=0; +#endif HV* stash=NULL; if (!(AMGf_noleft & flags) && SvAMAGIC(left) - && (mg = mg_find((SV*)(stash=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)) && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ - (fl = 1, cv = cvp[off=method])))) { + ( +#ifdef DEBUGGING + fl = 1, +#endif + cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { @@ -1476,8 +1505,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*)(stash=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)) @@ -1563,21 +1592,23 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) force_cpy = force_cpy || assign; } } +#ifdef DEBUGGING if (!notfound) { - DEBUG_o( Perl_deb(aTHX_ - "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", - AMG_id2name(off), - method+assignshift==off? "" : - " (initially `", - method+assignshift==off? "" : - AMG_id2name(method+assignshift), - method+assignshift==off? "" : "')", - flags & AMGf_unary? "" : - lr==1 ? " for right argument": " for left argument", - flags & AMGf_unary? " for argument" : "", - HvNAME(stash), - fl? ",\n\tassignment variant used": "") ); + DEBUG_o(Perl_deb(aTHX_ + "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", + AMG_id2name(off), + method+assignshift==off? "" : + " (initially `", + method+assignshift==off? "" : + AMG_id2name(method+assignshift), + method+assignshift==off? "" : "')", + flags & AMGf_unary? "" : + lr==1 ? " for right argument": " for left argument", + flags & AMGf_unary? " for argument" : "", + stash ? HvNAME(stash) : "null", + fl? ",\n\tassignment variant used": "") ); } +#endif /* Since we use shallow copy during assignment, we need * to dublicate the contents, probably calling user-supplied * version of copy operator @@ -1766,13 +1797,17 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ case '\014': /* $^L */ + 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':