X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=836fdb23d2de60d9afab13f463f0b4dfabfc37b0;hb=31686daff9c699afe57f28ff395bbc6d383a696c;hp=587d3dc58119ae55c7978e0e9fe3cc7cd13d2c18;hpb=155aba94f677ac771761a1f510964fe5b21524ed;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 587d3dc..836fdb2 100644 --- a/gv.c +++ b/gv.c @@ -106,7 +106,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; GvCVGEN(gv) = 0; GvEGV(gv) = gv; - sv_magic((SV*)gv, (SV*)gv, '*', name, len); + sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0); GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; @@ -372,7 +372,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { - if (strEQ(name,"import")) + if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(stash, name, nend - name, TRUE); @@ -418,6 +418,9 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) return Nullgv; cv = GvCV(gv); + if (!CvROOT(cv)) + return Nullgv; + /* * Inheriting AUTOLOAD for non-methods works ... for now. */ @@ -435,9 +438,18 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); + ENTER; + +#ifdef USE_THREADS + sv_lock((SV *)varstash); +#endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); + LEAVE; varsv = GvSV(vargv); +#ifdef USE_THREADS + sv_lock(varsv); +#endif sv_setpv(varsv, HvNAME(stash)); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); @@ -448,10 +460,10 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) /* =for apidoc gv_stashpv -Returns a pointer to the stash for a specified package. If C is -set then the package will be created if it does not already exist. If -C is not set and the package does not exist then NULL is -returned. +Returns a pointer to the stash for a specified package. C should +be a valid UTF-8 string. If C is set then the package will be +created if it does not already exist. If C is not set and the +package does not exist then NULL is returned. =cut */ @@ -494,8 +506,8 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) /* =for apidoc gv_stashsv -Returns a pointer to the stash for a specified package. See -C. +Returns a pointer to the stash for a specified package, which must be a +valid UTF-8 string. See C. =cut */ @@ -520,7 +532,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) I32 len; register const char *namend; HV *stash = 0; - U32 add_gvflags = 0; if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ name++; @@ -631,7 +642,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) sv_type == SVt_PVHV ? '%' : '$', name); if (GvCVu(*gvp)) - Perl_warn(aTHX_ "(Did you mean &%s instead?)\n", name); + Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); stash = 0; } } @@ -653,8 +664,10 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" : ""), name)); + stash = PL_nullstash; } - return Nullgv; + else + return Nullgv; } if (!SvREFCNT(stash)) /* symbol table under destruction */ @@ -680,7 +693,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); - GvFLAGS(gv) |= add_gvflags; if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE)) GvMULTI_on(gv) ; @@ -907,6 +919,22 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) } void +Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) +{ + HV *hv = GvSTASH(gv); + if (!hv) { + (void)SvOK_off(sv); + return; + } + sv_setpv(sv, prefix ? prefix : ""); + if (keepmain || strNE(HvNAME(hv), "main")) { + sv_catpv(sv,HvNAME(hv)); + sv_catpvn(sv,"::", 2); + } + sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); +} + +void Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { HV *hv = GvSTASH(gv); @@ -921,6 +949,15 @@ Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) } void +Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) +{ + GV *egv = GvEGV(gv); + if (!egv) + egv = gv; + gv_fullname4(sv, egv, prefix, keepmain); +} + +void Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { GV *egv = GvEGV(gv); @@ -1580,3 +1617,110 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } } } + +/* +=for apidoc is_gv_magical + +Returns C if given the name of a magical GV. + +Currently only useful internally when determining if a GV should be +created even in rvalue contexts. + +C is not used at present but available for future extension to +allow selecting particular classes of magical variable. + +=cut +*/ +bool +Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) +{ + if (!len) + return FALSE; + + switch (*name) { + case 'I': + if (len == 3 && strEQ(name, "ISA")) + goto yes; + break; + case 'O': + if (len == 8 && strEQ(name, "OVERLOAD")) + goto yes; + break; + case 'S': + if (len == 3 && strEQ(name, "SIG")) + goto yes; + break; + case '\027': /* $^W & $^WARNING_BITS */ + if (len == 1 + || (len == 12 && strEQ(name, "\027ARNING_BITS")) + || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS"))) + { + goto yes; + } + break; + + case '&': + case '`': + case '\'': + case ':': + case '?': + case '!': + case '-': + case '#': + case '*': + case '[': + case '^': + case '~': + case '=': + case '%': + case '.': + case '(': + case ')': + case '<': + case '>': + case ',': + case '\\': + case '/': + case '|': + case '+': + case ';': + case ']': + 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 '\014': /* $^L */ + case '\017': /* $^O */ + case '\020': /* $^P */ + case '\023': /* $^S */ + case '\024': /* $^T */ + case '\026': /* $^V */ + if (len == 1) + goto yes; + break; + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + if (len > 1) { + char *end = name + len; + while (--end > name) { + if (!isDIGIT(*end)) + return FALSE; + } + } + yes: + return TRUE; + default: + break; + } + return FALSE; +}