X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e94ea821c9b12318e87433760bdeb91530114733..c62c27bf164f6671b74cfff2449a8b553f7081ae:/gv.c diff --git a/gv.c b/gv.c index cd1c32d..3237c53 100644 --- a/gv.c +++ b/gv.c @@ -1008,11 +1008,11 @@ Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags) GV * Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags) { - const char *nend; - const char *nsplit = NULL; + const char * const origname = name; + const char * const name_end = name + len; + const char *last_separator = NULL; GV* gv; HV* ostash = stash; - const char * const origname = name; SV *const error_report = MUTABLE_SV(stash); const U32 autoload = flags & GV_AUTOLOAD; const U32 do_croak = flags & GV_CROAK; @@ -1023,43 +1023,60 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le if (SvTYPE(stash) < SVt_PVHV) stash = NULL; else { - /* The only way stash can become NULL later on is if nsplit is set, + /* The only way stash can become NULL later on is if last_separator is set, which in turn means that there is no need for a SVt_PVHV case the error reporting code. */ } - for (nend = name; *nend || nend != (origname + len); nend++) { - if (*nend == '\'') { - nsplit = nend; - name = nend + 1; - } - else if (*nend == ':' && *(nend + 1) == ':') { - nsplit = nend++; - name = nend + 1; - } + { + /* check if the method name is fully qualified or + * not, and separate the package name from the actual + * method name. + * + * leaves last_separator pointing to the beginning of the + * last package separator (either ' or ::) or 0 + * if none was found. + * + * leaves name pointing at the beginning of the + * method name. + */ + const char *name_cursor = name; + const char * const name_em1 = name_end - 1; /* name_end minus 1 */ + for (name_cursor = name; name_cursor < name_end ; name_cursor++) { + if (*name_cursor == '\'') { + last_separator = name_cursor; + name = name_cursor + 1; + } + else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') { + last_separator = name_cursor++; + name = name_cursor + 1; + } + } } - if (nsplit) { - if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) { + + /* did we find a separator? */ + if (last_separator) { + if ((last_separator - origname) == 5 && memEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ stash = CopSTASH(PL_curcop); flags |= GV_SUPER; DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvENAME_get(stash), name) ); } - else if ((nsplit - origname) >= 7 && - strnEQ(nsplit - 7, "::SUPER", 7)) { + else if ((last_separator - origname) >= 7 && + strnEQ(last_separator - 7, "::SUPER", 7)) { /* don't autovifify if ->NoSuchStash::SUPER::method */ - stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8); + stash = gv_stashpvn(origname, last_separator - origname - 7, is_utf8); if (stash) flags |= GV_SUPER; } else { /* don't autovifify if ->NoSuchStash::method */ - stash = gv_stashpvn(origname, nsplit - origname, is_utf8); + stash = gv_stashpvn(origname, last_separator - origname, is_utf8); } ostash = stash; } - gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); + gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); if (!gv) { /* This is the special case that exempts Foo->import and Foo->unimport from being an error even if there's no @@ -1068,7 +1085,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le gv = MUTABLE_GV(&PL_sv_yes); else if (autoload) gv = gv_autoload_pvn( - ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags + ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags ); if (!gv && do_croak) { /* Right now this is exclusively for the benefit of S_method_common @@ -1084,21 +1101,21 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le HV_FETCH_ISEXISTS, NULL, 0) ) { require_pv("IO/File.pm"); - gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); + gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); if (gv) return gv; } Perl_croak(aTHX_ "Can't locate object method \"%"UTF8f "\" via package \"%"HEKf"\"", - UTF8fARG(is_utf8, nend - name, name), + UTF8fARG(is_utf8, name_end - name, name), HEKfARG(HvNAME_HEK(stash))); } else { SV* packnamesv; - if (nsplit) { - packnamesv = newSVpvn_flags(origname, nsplit - origname, + if (last_separator) { + packnamesv = newSVpvn_flags(origname, last_separator - origname, SVs_TEMP | is_utf8); } else { packnamesv = error_report; @@ -1108,7 +1125,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le "Can't locate object method \"%"UTF8f "\" via package \"%"SVf"\"" " (perhaps you forgot to load \"%"SVf"\"?)", - UTF8fARG(is_utf8, nend - name, name), + UTF8fARG(is_utf8, name_end - name, name), SVfARG(packnamesv), SVfARG(packnamesv)); } } @@ -1298,18 +1315,16 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) * with the passed gv as an argument. * * The "gv" parameter should be the glob. - * "varpv" holds the name of the var, used for error messages. + * "varname" holds the 1-char name of the var, used for error messages. * "namesv" holds the module name. Its refcount will be decremented. * "flags": if flag & 1 then save the scalar before loading. * For the protection of $! to work (it is set by this routine) * the sv slot must already be magicalized. */ STATIC void -S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const U32 flags) +S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, + STRLEN len, const U32 flags) { - const char varname = *varpv; /* varpv might be clobbered by - load_module, so save it. For the - moment it’s always a single char. */ const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv); PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; @@ -1324,27 +1339,26 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const U32 flags) dSP; ENTER; - SAVEFREESV(namesv); #define HV_FETCH_TIE_FUNC (GV **)hv_fetch(stash, "_tie_it", 7, 0) /* Load the module if it is not loaded. */ - if (!(stash = gv_stashsv(namesv, 0)) + if (!(stash = gv_stashpvn(name, len, 0)) || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) { - SV *module = newSVsv(namesv); + SV * const module = newSVpvn(name, len); const char type = varname == '[' ? '$' : '%'; if ( flags & 1 ) save_scalar(gv); Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); assert(sp == PL_stack_sp); - stash = gv_stashsv(namesv, 0); + stash = gv_stashpvn(name, len, 0); if (!stash) - Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available", - type, varname, SVfARG(namesv)); + Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", + type, varname, name); else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) - Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not define _tie_it", - type, varname, SVfARG(namesv)); + Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", + type, varname, name); } /* Now call the tie function. It should be in *gvp. */ assert(gvp); assert(*gvp); assert(GvCV(*gvp)); @@ -1354,7 +1368,6 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const U32 flags) call_sv((SV *)*gvp, G_VOID|G_DISCARD); LEAVE; } - else SvREFCNT_dec_NN(namesv); } /* @@ -1450,7 +1463,7 @@ S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags) gv_stashsvpvn_cached Returns a pointer to the stash for a specified package, possibly -cached. Implements both C and C. +cached. Implements both C and C. Requires one of either namesv or namepv to be non-null. @@ -1815,15 +1828,14 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, * Note that it does not insert the GV into the stash prior to * magicalization, which some variables require need in order * to work (like $[, %+, %-, %!), so callers must take care of - * that beforehand. + * that. * - * The return value has a specific meaning for gv_fetchpvn_flags: - * If it returns true, and the gv is empty, it indicates that its - * refcount should be decreased. + * It returns true if the gv did turn out to be magical one; i.e., + * if gv_magicalize actually did something. */ PERL_STATIC_INLINE bool S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, - bool addmg, const svtype sv_type) + const svtype sv_type) { SSize_t paren; @@ -1860,7 +1872,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, default: goto try_core; } - return addmg; + goto ret; } try_core: if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { @@ -2011,7 +2023,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, this test */ UV uv; if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX) - return addmg; + goto ret; /* XXX why are we using a SSize_t? */ paren = (SSize_t)(I32)uv; goto storeparen; @@ -2082,7 +2094,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, /* magicalization must be done before require_tie_mod is called */ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod(gv, "!", newSVpvs("Errno"), 1); + require_tie_mod(gv, '!', "Errno", 5, 1); break; case '-': /* $- */ @@ -2099,7 +2111,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, SvREADONLY_on(av); if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), 0); + require_tie_mod(gv, *name, "Tie::Hash::NamedCapture",23,0); break; } @@ -2119,7 +2131,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case '[': /* $[ */ if ((sv_type == SVt_PV || sv_type == SVt_PVGV) && FEATURE_ARYBASE_IS_ENABLED) { - require_tie_mod(gv,name,newSVpvs("arybase"),0); + require_tie_mod(gv,'[',"arybase",7,0); } else goto magicalize; break; @@ -2187,7 +2199,13 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, } } - return addmg; + ret: + /* Return true if we actually did something. */ + return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) + || ( GvSV(gv) && ( + SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)) + ) + ); } /* If we do ever start using this later on in the file, we need to make @@ -2207,9 +2225,9 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) { if (*name == '!') - require_tie_mod(gv, "!", newSVpvs("Errno"), 1); + require_tie_mod(gv, '!', "Errno", 5, 1); else if (*name == '-' || *name == '+') - require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), 0); + require_tie_mod(gv, *name, "Tie::Hash::NamedCapture", 23, 0); } else if (sv_type == SVt_PV) { if (*name == '*' || *name == '#') { /* diag_listed_as: $* is no longer supported */ @@ -2221,7 +2239,7 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) if (sv_type==SVt_PV || sv_type==SVt_PVGV) { switch (*name) { case '[': - require_tie_mod(gv,name,newSVpvs("arybase"),0); + require_tie_mod(gv,'[',"arybase",7,0); break; #ifdef PERL_SAWAMPERSAND case '`': @@ -2350,29 +2368,22 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) ) GvMULTI_on(gv) ; -#define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \ - || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv)))) - /* set up magic where warranted */ - if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) { + if ( gv_magicalize(gv, stash, name, len, sv_type) ) { /* See 23496c6 */ - if (GvEMPTY(gv)) { - if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) { - /* The GV was and still is "empty", except that now - * it has the magic flags turned on, so we want it + if (addmg) { + /* gv_magicalize magicalised this gv, so we want it * stored in the symtab. + * Effectively the caller is asking, ‘Does this gv exist?’ + * And we respond, ‘Er, *now* it does!’ */ (void)hv_store(stash,name,len,(SV *)gv,0); - } - else { - /* Most likely the temporary GV created above */ + } + } + else if (addmg) { + /* The temporary GV created above */ SvREFCNT_dec_NN(gv); gv = NULL; - } - } - else - /* Not empty; this means gv_magicalize magicalised it. */ - (void)hv_store(stash,name,len,(SV *)gv,0); } if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);