X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e167a7177da799ca1757dc382b386abd3ae29491..64afbd292eada08042044fb6bc5a8dabf803ec53:/gv.c diff --git a/gv.c b/gv.c index 1e2f515..ae800c9 100644 --- a/gv.c +++ b/gv.c @@ -84,7 +84,7 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) { *where = newSV_type(type); if (type == SVt_PVAV && GvNAMELEN(gv) == 3 - && strnEQ(GvNAME(gv), "ISA", 3)) + && strEQs(GvNAME(gv), "ISA")) sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); } return gv; @@ -770,7 +770,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, } else if (stash == cachestash && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4 - && strnEQ(hvname, "CORE", 4) + && strEQs(hvname, "CORE") && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len)) goto have_gv; } @@ -785,7 +785,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, if (!cstash) { Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for @%"HEKf"::ISA", + "Can't locate package %" SVf " for @%" HEKf "::ISA", SVfARG(linear_sv), HEKfARG(HvNAME_HEK(stash))); continue; @@ -797,7 +797,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, if (!gvp) { if (len > 1 && HvNAMELEN_get(cstash) == 4) { const char *hvname = HvNAME(cstash); assert(hvname); - if (strnEQ(hvname, "CORE", 4) + if (strEQs(hvname, "CORE") && (candidate = S_maybe_add_coresub(aTHX_ cstash,NULL,name,len) )) @@ -1003,16 +1003,14 @@ Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags) return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags); } -/* Don't merge this yet, as it's likely to get a len parameter, and possibly - even a U32 hash */ 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 +1021,61 @@ 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) { + STRLEN sep_len= last_separator - origname; + if ( memEQs(origname, sep_len, "SUPER")) { /* ->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 ( sep_len >= 7 && + strEQs(last_separator - 7, "::SUPER")) { /* don't autovifify if ->NoSuchStash::SUPER::method */ - stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8); + stash = gv_stashpvn(origname, sep_len - 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, sep_len, 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 +1084,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,31 +1100,31 @@ 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), + "Can't locate object method \"%" UTF8f + "\" via package \"%" HEKf "\"", + 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; } Perl_croak(aTHX_ - "Can't locate object method \"%"UTF8f - "\" via package \"%"SVf"\"" - " (perhaps you forgot to load \"%"SVf"\"?)", - UTF8fARG(is_utf8, nend - name, name), + "Can't locate object method \"%" UTF8f + "\" via package \"%" SVf "\"" + " (perhaps you forgot to load \"%" SVf "\"?)", + UTF8fARG(is_utf8, name_end - name, name), SVfARG(packnamesv), SVfARG(packnamesv)); } } @@ -1200,8 +1216,9 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) && (GvCVGEN(gv) || GvSTASH(gv) != stash) ) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Use of inherited AUTOLOAD for non-method %"SVf - "::%"UTF8f"() is deprecated", + "Use of inherited AUTOLOAD for non-method %" SVf + "::%" UTF8f "() is deprecated. This will be " + "fatal in Perl 5.28", SVfARG(packname), UTF8fARG(is_utf8, len, name)); @@ -1298,19 +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, const char * name, +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; @@ -1326,27 +1340,25 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, const char * name, ENTER; -#define HV_FETCH_TIE_FUNC (GV **)hv_fetch(stash, "_tie_it", 7, 0) +#define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0) /* Load the module if it is not loaded. */ if (!(stash = gv_stashpvn(name, len, 0)) || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) { - SV * const namesv = newSVpvn(name, len); + SV * const module = newSVpvn(name, len); const char type = varname == '[' ? '$' : '%'; - SAVEFREESV(namesv); if ( flags & 1 ) save_scalar(gv); - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - SvREFCNT_inc_NN(namesv), NULL); + 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)); @@ -1358,6 +1370,13 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, const char * name, } } +/* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes, + * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in + * a true string WITHOUT a len. + */ +#define require_tie_mod_s(gv, varname, name, flags) \ + S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags) + /* =for apidoc gv_stashpv @@ -1573,7 +1592,10 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME; - if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) { + if ( full_len > 2 + && **name == '*' + && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8)) + { /* accidental stringify on a GV? */ (*name)++; } @@ -1621,8 +1643,8 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, *stash = GvHV(*gv) = newHV(); if (!HvNAME_get(*stash)) { if (GvSTASH(*gv) == PL_defstash && *len == 6 - && strnEQ(*name, "CORE", 4)) - hv_name_set(*stash, "CORE", 4, 0); + && strEQs(*name, "CORE")) + hv_name_sets(*stash, "CORE", 0); else hv_name_set( *stash, nambeg, name_cursor-nambeg, is_utf8 @@ -1641,8 +1663,15 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, name_cursor++; *name = name_cursor+1; if (*name == name_end) { - if (!*gv) - *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); + if (!*gv) { + *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); + if (SvTYPE(*gv) != SVt_PVGV) { + gv_init_pvn(*gv, PL_defstash, "main::", 6, + GV_ADDMULTI); + GvHV(*gv) = + MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); + } + } return TRUE; } } @@ -1658,7 +1687,7 @@ S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8) PERL_ARGS_ASSERT_GV_IS_IN_MAIN; /* If it's an alphanumeric variable */ - if ( len && isIDFIRST_lazy_if(name, is_utf8) ) { + if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) { /* Some "normal" variables are always in main::, * like INC or STDOUT. */ @@ -1748,14 +1777,14 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, /* diag_listed_as: Variable "%s" is not imported%s */ Perl_ck_warner_d( aTHX_ packWARN(WARN_MISC), - "Variable \"%c%"UTF8f"\" is not imported", + "Variable \"%c%" UTF8f "\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', UTF8fARG(is_utf8, len, name)); if (GvCVu(*gvp)) Perl_ck_warner_d( aTHX_ packWARN(WARN_MISC), - "\t(Did you mean &%"UTF8f" instead?)\n", + "\t(Did you mean &%" UTF8f " instead?)\n", UTF8fARG(is_utf8, len, name) ); *stash = NULL; @@ -1772,9 +1801,9 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, if (add && !PL_in_clean_all) { GV *gv; qerror(Perl_mess(aTHX_ - "Global symbol \"%s%"UTF8f + "Global symbol \"%s%" UTF8f "\" requires explicit package name (did you forget to " - "declare \"my %s%"UTF8f"\"?)", + "declare \"my %s%" UTF8f "\"?)", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" @@ -1816,15 +1845,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; @@ -1835,25 +1863,31 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, and VERSION. All the others apply only to the main stash or to CORE (which is checked right after this). */ if (len) { - const char * const name2 = name + 1; switch (*name) { case 'E': - if (strnEQ(name2, "XPORT", 5)) + if ( + len >= 6 && name[1] == 'X' && + (memEQs(name, len, "EXPORT") + ||memEQs(name, len, "EXPORT_OK") + ||memEQs(name, len, "EXPORT_FAIL") + ||memEQs(name, len, "EXPORT_TAGS")) + ) GvMULTI_on(gv); break; case 'I': - if (strEQ(name2, "SA")) + if (memEQs(name, len, "ISA")) gv_magicalize_isa(gv); break; case 'V': - if (strEQ(name2, "ERSION")) + if (memEQs(name, len, "VERSION")) GvMULTI_on(gv); break; case 'a': - if (stash == PL_debstash && len==4 && strEQ(name2,"rgs")) { + if (stash == PL_debstash && memEQs(name, len, "args")) { GvMULTI_on(gv_AVadd(gv)); break; - } + } + /* FALLTHROUGH */ case 'b': if (len == 1 && sv_type == SVt_PV) GvMULTI_on(gv); @@ -1861,13 +1895,13 @@ 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) { /* Avoid null warning: */ const char * const stashname = HvNAME(stash); assert(stashname); - if (strnEQ(stashname, "CORE", 4)) + if (strEQs(stashname, "CORE")) S_maybe_add_coresub(aTHX_ 0, gv, name, len); } } @@ -1888,27 +1922,32 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, } else #endif { - const char * name2 = name + 1; switch (*name) { case 'A': - if (strEQ(name2, "RGV")) { + if (memEQs(name, len, "ARGV")) { IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; } - else if (strEQ(name2, "RGVOUT")) { + else if (memEQs(name, len, "ARGVOUT")) { GvMULTI_on(gv); } break; case 'E': - if (strnEQ(name2, "XPORT", 5)) + if ( + len >= 6 && name[1] == 'X' && + (memEQs(name, len, "EXPORT") + ||memEQs(name, len, "EXPORT_OK") + ||memEQs(name, len, "EXPORT_FAIL") + ||memEQs(name, len, "EXPORT_TAGS")) + ) GvMULTI_on(gv); break; case 'I': - if (strEQ(name2, "SA")) { + if (memEQs(name, len, "ISA")) { gv_magicalize_isa(gv); } break; case 'S': - if (strEQ(name2, "IG")) { + if (memEQs(name, len, "SIG")) { HV *hv; I32 i; if (!PL_psig_name) { @@ -1939,62 +1978,78 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, } break; case 'V': - if (strEQ(name2, "ERSION")) + if (memEQs(name, len, "VERSION")) GvMULTI_on(gv); break; case '\003': /* $^CHILD_ERROR_NATIVE */ - if (strEQ(name2, "HILD_ERROR_NATIVE")) + if (memEQs(name, len, "\003HILD_ERROR_NATIVE")) goto magicalize; + /* @{^CAPTURE} %{^CAPTURE} */ + if (memEQs(name, len, "\003APTURE")) { + AV* const av = GvAVn(gv); + UV uv= *name; + + sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0); + SvREADONLY_on(av); + + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); + + } else /* %{^CAPTURE_ALL} */ + if (memEQs(name, len, "\003APTURE_ALL")) { + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0); + } break; case '\005': /* $^ENCODING */ - if (strEQ(name2, "NCODING")) + if (memEQs(name, len, "\005NCODING")) goto magicalize; break; case '\007': /* $^GLOBAL_PHASE */ - if (strEQ(name2, "LOBAL_PHASE")) + if (memEQs(name, len, "\007LOBAL_PHASE")) goto ro_magicalize; break; case '\014': /* $^LAST_FH */ - if (strEQ(name2, "AST_FH")) + if (memEQs(name, len, "\014AST_FH")) goto ro_magicalize; break; case '\015': /* $^MATCH */ - if (strEQ(name2, "ATCH")) { + if (memEQs(name, len, "\015ATCH")) { paren = RX_BUFF_IDX_CARET_FULLMATCH; goto storeparen; } break; case '\017': /* $^OPEN */ - if (strEQ(name2, "PEN")) + if (memEQs(name, len, "\017PEN")) goto magicalize; break; case '\020': /* $^PREMATCH $^POSTMATCH */ - if (strEQ(name2, "REMATCH")) { + if (memEQs(name, len, "\020REMATCH")) { paren = RX_BUFF_IDX_CARET_PREMATCH; goto storeparen; } - if (strEQ(name2, "OSTMATCH")) { + if (memEQs(name, len, "\020OSTMATCH")) { paren = RX_BUFF_IDX_CARET_POSTMATCH; goto storeparen; } break; case '\024': /* ${^TAINT} */ - if (strEQ(name2, "AINT")) + if (memEQs(name, len, "\024AINT")) goto ro_magicalize; break; case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ - if (strEQ(name2, "NICODE")) + if (memEQs(name, len, "\025NICODE")) goto ro_magicalize; - if (strEQ(name2, "TF8LOCALE")) + if (memEQs(name, len, "\025TF8LOCALE")) goto ro_magicalize; - if (strEQ(name2, "TF8CACHE")) + if (memEQs(name, len, "\025TF8CACHE")) goto magicalize; break; case '\027': /* $^WARNING_BITS */ - if (strEQ(name2, "ARNING_BITS")) + if (memEQs(name, len, "\027ARNING_BITS")) goto magicalize; #ifdef WIN32 - else if (strEQ(name2, "IN32_SLOPPY_STAT")) + else if (memEQs(name, len, "\027IN32_SLOPPY_STAT")) goto magicalize; #endif break; @@ -2012,7 +2067,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; @@ -2081,35 +2136,38 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); - /* magicalization must be done before require_tie_mod is called */ + /* magicalization must be done before require_tie_mod_s is called */ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod(gv, "!", "Errno", 5, 1); + require_tie_mod_s(gv, '!', "Errno", 1); break; - case '-': /* $- */ - case '+': /* $+ */ - GvMULTI_on(gv); /* no used once warnings here */ - { - AV* const av = GvAVn(gv); - SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; - - sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); - if (avc) - SvREADONLY_on(GvSVn(gv)); - SvREADONLY_on(av); - - if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod(gv, name, "Tie::Hash::NamedCapture",23, 0); + case '-': /* $-, %-, @- */ + case '+': /* $+, %+, @+ */ + GvMULTI_on(gv); /* no used once warnings here */ + { /* $- $+ */ + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + if (*name == '+') + SvREADONLY_on(GvSVn(gv)); + } + { /* %- %+ */ + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0); + } + { /* @- @+ */ + AV* const av = GvAVn(gv); + const UV uv = (UV)*name; + sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0); + SvREADONLY_on(av); + } break; - } case '*': /* $* */ case '#': /* $# */ if (sv_type == SVt_PV) - /* diag_listed_as: $* is no longer supported */ + /* diag_listed_as: $* is no longer supported. Its use will be fatal in Perl 5.30 */ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "$%c is no longer supported", *name); + "$%c is no longer supported. Its use " + "will be fatal in Perl 5.30", *name); break; case '\010': /* $^H */ { @@ -2120,7 +2178,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,"arybase",7,0); + require_tie_mod_s(gv,'[',"arybase",0); } else goto magicalize; break; @@ -2188,7 +2246,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 @@ -2208,21 +2272,22 @@ 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, "!", "Errno", 5, 1); + require_tie_mod_s(gv, '!', "Errno", 1); else if (*name == '-' || *name == '+') - require_tie_mod(gv, name, "Tie::Hash::NamedCapture", 23, 0); + require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0); } else if (sv_type == SVt_PV) { if (*name == '*' || *name == '#') { - /* diag_listed_as: $* is no longer supported */ + /* diag_listed_as: $# is no longer supported. Its use will be fatal in Perl 5.30 */ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "$%c is no longer supported", *name); + "$%c is no longer supported. Its use " + "will be fatal in Perl 5.30", *name); } } if (sv_type==SVt_PV || sv_type==SVt_PVGV) { switch (*name) { case '[': - require_tie_mod(gv,name,"arybase",7,0); + require_tie_mod_s(gv,'[',"arybase",0); break; #ifdef PERL_SAWAMPERSAND case '`': @@ -2313,7 +2378,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, maybe_multimagic_gv(gv, name, sv_type); } else if (len == 3 && sv_type == SVt_PVAV - && strnEQ(name, "ISA", 3) + && strEQs(name, "ISA") && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) gv_magicalize_isa(gv); } @@ -2344,36 +2409,33 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (add & GV_ADDWARN) Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Had to create %"UTF8f" unexpectedly", + "Had to create %" UTF8f " unexpectedly", UTF8fARG(is_utf8, name_end-nambeg, nambeg)); gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); - if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) ) + if ( full_len != 0 + && isIDFIRST_lazy_if_safe(name, name + full_len, 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); @@ -2447,8 +2509,12 @@ Perl_gv_check(pTHX_ HV *stash) ) gv_check(hv); /* nested package */ } - else if ( *HeKEY(entry) != '_' - && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) { + else if ( HeKLEN(entry) != 0 + && *HeKEY(entry) != '_' + && isIDFIRST_lazy_if_safe(HeKEY(entry), + HeKEY(entry) + HeKLEN(entry), + HeUTF8(entry)) ) + { const char *file; gv = MUTABLE_GV(HeVAL(entry)); if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) @@ -2462,7 +2528,7 @@ Perl_gv_check(pTHX_ HV *stash) = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif Perl_warner(aTHX_ packWARN(WARN_ONCE), - "Name \"%"HEKf"::%"HEKf + "Name \"%" HEKf "::%" HEKf "\" used only once: possible typo", HEKfARG(HvNAME_HEK(stash)), HEKfARG(GvNAME_HEK(gv))); @@ -2478,7 +2544,7 @@ Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; assert(!(flags & ~SVf_UTF8)); - return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld", + return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld", UTF8fARG(flags, strlen(pack), pack), (long)PL_gensym++), GV_ADD, SVt_PVGV); @@ -2558,7 +2624,7 @@ Perl_gp_free(pTHX_ GV *gv) const HEK *hvname_hek = HvNAME_HEK(hv); if (PL_stashcache && hvname_hek) { DEBUG_o(Perl_deb(aTHX_ - "gp_free clearing PL_stashcache for '%"HEKf"'\n", + "gp_free clearing PL_stashcache for '%" HEKf "'\n", HEKfARG(hvname_hek))); (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); } @@ -2727,7 +2793,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) GV *ngv = NULL; SV *gvsv = GvSV(gv); - DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ + DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\ "\" for overloaded \"%s\" in package \"%.256s\"\n", (void*)GvSV(gv), cp, HvNAME(stash)) ); if (!gvsv || !SvPOK(gvsv) @@ -2742,9 +2808,9 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) ? gvsv : newSVpvs_flags("???", SVs_TEMP); /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ - Perl_croak(aTHX_ "%s method \"%"SVf256 + Perl_croak(aTHX_ "%s method \"%" SVf256 "\" overloading \"%s\" "\ - "in package \"%"HEKf256"\"", + "in package \"%" HEKf256 "\"", (GvCVGEN(gv) ? "Stub found while resolving" : "Can't resolve"), SVfARG(name), cp, @@ -3230,7 +3296,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV *msg; if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf, + "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf, AMG_id2name(method + assignshift), (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? @@ -3248,9 +3314,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))): SVfARG(&PL_sv_no))); if (use_default_op) { - DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) ); + DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) ); } else { - Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); + Perl_croak(aTHX_ "%" SVf, SVfARG(msg)); } return NULL; } @@ -3321,7 +3387,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ - "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n", + "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n", AMG_id2name(off), method+assignshift==off? "" : " (initially \"", @@ -3508,7 +3574,7 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) PERL_ARGS_ASSERT_GV_NAME_SET; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); + Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len); if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { unshare_hek(GvNAME_HEK(gv));