if (SvTYPE(gv) == SVt_PVGV)
return cv_const_sv(GvCVu(gv));
- return SvROK(gv) ? SvRV(gv) : NULL;
+ return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
}
GP *
const char *file;
STRLEN len;
#ifndef USE_ITHREADS
- SV * temp_sv;
+ GV *filegv;
#endif
dVAR;
gp->gp_sv = newSV(0);
#endif
-#ifdef USE_ITHREADS
+ /* PL_curcop may be null here. E.g.,
+ INIT { bless {} and exit }
+ frees INIT before looking up DESTROY (and creating *DESTROY)
+ */
if (PL_curcop) {
gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
+#ifdef USE_ITHREADS
if (CopFILE(PL_curcop)) {
file = CopFILE(PL_curcop);
len = strlen(file);
}
+#else
+ filegv = CopFILEGV(PL_curcop);
+ if (filegv) {
+ file = GvNAME(filegv)+2;
+ len = GvNAMELEN(filegv)-2;
+ }
+#endif
else goto no_file;
}
else {
file = "";
len = 0;
}
-#else
- if(PL_curcop)
- gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
- temp_sv = CopFILESV(PL_curcop);
- if (temp_sv) {
- file = SvPVX(temp_sv);
- len = SvCUR(temp_sv);
- } else {
- file = "";
- len = 0;
- }
-#endif
PERL_HASH(hash, file, len);
gp->gp_file_hek = share_hek(file, len, hash);
if (has_constant) {
/* The constant has to be a simple scalar type. */
switch (SvTYPE(has_constant)) {
- case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
case SVt_PVFM:
topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
if (flags & GV_SUPER) {
- if (!HvAUX(stash)->xhv_super) HvAUX(stash)->xhv_super = newHV();
- cachestash = HvAUX(stash)->xhv_super;
+ if (!HvAUX(stash)->xhv_mro_meta->super)
+ HvAUX(stash)->xhv_mro_meta->super = newHV();
+ cachestash = HvAUX(stash)->xhv_mro_meta->super;
}
else cachestash = stash;
return gv;
}
Perl_croak(aTHX_
- "Can't locate object method \"%"SVf
+ "Can't locate object method \"%"UTF8f
"\" via package \"%"HEKf"\"",
- SVfARG(newSVpvn_flags(name, nend - name,
- SVs_TEMP | is_utf8)),
+ UTF8fARG(is_utf8, nend - name, name),
HEKfARG(HvNAME_HEK(stash)));
}
else {
packnamesv = newSVpvn_flags(origname, nsplit - origname,
SVs_TEMP | is_utf8);
} else {
- packnamesv = sv_2mortal(newSVsv(error_report));
+ packnamesv = error_report;
}
Perl_croak(aTHX_
- "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
+ "Can't locate object method \"%"UTF8f
+ "\" via package \"%"SVf"\""
" (perhaps you forgot to load \"%"SVf"\"?)",
- SVfARG(newSVpvn_flags(name, nend - name,
- SVs_TEMP | is_utf8)),
+ UTF8fARG(is_utf8, nend - name, name),
SVfARG(packnamesv), SVfARG(packnamesv));
}
}
&& (GvCVGEN(gv) || GvSTASH(gv) != stash)
)
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
+ "Use of inherited AUTOLOAD for non-method %"SVf
+ "::%"UTF8f"() is deprecated",
SVfARG(packname),
- SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
+ UTF8fARG(is_utf8, len, name));
if (CvISXSUB(cv)) {
/* Instead of forcing the XSUB do another lookup for $AUTOLOAD
return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
}
-STATIC void
+PERL_STATIC_INLINE void
S_gv_magicalize_isa(pTHX_ GV *gv)
{
AV* av;
NULL, 0);
}
-GV *
-Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
- const svtype sv_type)
+/* This function grabs name and tries to split a stash and glob
+ * from its contents. TODO better description, comments
+ *
+ * If the function returns TRUE and 'name == name_end', then
+ * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
+ */
+PERL_STATIC_INLINE bool
+S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
+ STRLEN *len, const char *nambeg, STRLEN full_len,
+ const U32 is_utf8, const I32 add)
{
- dVAR;
- const char *name = nambeg;
- GV *gv = NULL;
- GV**gvp;
- I32 len;
const char *name_cursor;
- HV *stash = NULL;
- const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
- const I32 no_expand = flags & GV_NOEXPAND;
- const I32 add = flags & ~GV_NOADD_MASK;
- const U32 is_utf8 = flags & SVf_UTF8;
- bool addmg = !!(flags & GV_ADDMG);
const char *const name_end = nambeg + full_len;
const char *const name_em1 = name_end - 1;
- U32 faking_it;
-
- PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
- if (flags & GV_NOTQUAL) {
- /* Caller promised that there is no stash, so we can skip the check. */
- len = full_len;
- goto no_stash;
+ PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
+
+ if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) {
+ /* accidental stringify on a GV? */
+ (*name)++;
}
- if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
- /* accidental stringify on a GV? */
- name++;
- }
-
- for (name_cursor = name; name_cursor < name_end; name_cursor++) {
- if (name_cursor < name_em1 &&
- ((*name_cursor == ':'
- && name_cursor[1] == ':')
- || *name_cursor == '\''))
- {
- if (!stash)
- stash = PL_defstash;
- if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
- return NULL;
-
- len = name_cursor - name;
- if (name_cursor > nambeg) { /* Skip for initial :: or ' */
- const char *key;
- if (*name_cursor == ':') {
- key = name;
- len += 2;
- } else {
- char *tmpbuf;
- Newx(tmpbuf, len+2, char);
- Copy(name, tmpbuf, len, char);
- tmpbuf[len++] = ':';
- tmpbuf[len++] = ':';
- key = tmpbuf;
- }
- gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
- gv = gvp ? *gvp : NULL;
- if (gv && gv != (const GV *)&PL_sv_undef) {
- if (SvTYPE(gv) != SVt_PVGV)
- gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
- else
- GvMULTI_on(gv);
- }
- if (key != name)
- Safefree(key);
- if (!gv || gv == (const GV *)&PL_sv_undef)
- return NULL;
-
- if (!(stash = GvHV(gv)))
- {
- 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);
- else
- hv_name_set(
- stash, nambeg, name_cursor-nambeg, is_utf8
- );
- /* If the containing stash has multiple effective
- names, see that this one gets them, too. */
- if (HvAUX(GvSTASH(gv))->xhv_name_count)
- mro_package_moved(stash, NULL, gv, 1);
- }
- }
- else if (!HvNAME_get(stash))
- hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
- }
+ for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
+ if (name_cursor < name_em1 &&
+ ((*name_cursor == ':' && name_cursor[1] == ':')
+ || *name_cursor == '\''))
+ {
+ if (!*stash)
+ *stash = PL_defstash;
+ if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
+ return FALSE;
+
+ *len = name_cursor - *name;
+ if (name_cursor > nambeg) { /* Skip for initial :: or ' */
+ const char *key;
+ GV**gvp;
+ if (*name_cursor == ':') {
+ key = *name;
+ *len += 2;
+ }
+ else {
+ char *tmpbuf;
+ Newx(tmpbuf, *len+2, char);
+ Copy(*name, tmpbuf, *len, char);
+ tmpbuf[(*len)++] = ':';
+ tmpbuf[(*len)++] = ':';
+ key = tmpbuf;
+ }
+ gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -(*len) : *len, add);
+ *gv = gvp ? *gvp : NULL;
+ if (*gv && *gv != (const GV *)&PL_sv_undef) {
+ if (SvTYPE(*gv) != SVt_PVGV)
+ gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
+ else
+ GvMULTI_on(*gv);
+ }
+ if (key != *name)
+ Safefree(key);
+ if (!*gv || *gv == (const GV *)&PL_sv_undef)
+ return FALSE;
+
+ if (!(*stash = GvHV(*gv))) {
+ *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);
+ else
+ hv_name_set(
+ *stash, nambeg, name_cursor-nambeg, is_utf8
+ );
+ /* If the containing stash has multiple effective
+ names, see that this one gets them, too. */
+ if (HvAUX(GvSTASH(*gv))->xhv_name_count)
+ mro_package_moved(*stash, NULL, *gv, 1);
+ }
+ }
+ else if (!HvNAME_get(*stash))
+ hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
+ }
- if (*name_cursor == ':')
- name_cursor++;
- name = name_cursor+1;
- if (name == name_end)
- return gv
- ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
- }
+ if (*name_cursor == ':')
+ name_cursor++;
+ *name = name_cursor+1;
+ if (*name == name_end) {
+ if (!*gv)
+ *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
+ return TRUE;
+ }
+ }
}
- len = name_cursor - name;
-
- /* No stash in name, so see how we can default */
-
- if (!stash) {
- no_stash:
- if (len && isIDFIRST_lazy_if(name, is_utf8)) {
- bool global = FALSE;
-
- switch (len) {
- case 1:
- if (*name == '_')
- global = TRUE;
- break;
- case 3:
- if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
- || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
- || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
- global = TRUE;
- break;
- case 4:
- if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
- && name[3] == 'V')
- global = TRUE;
- break;
- case 5:
- if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
- && name[3] == 'I' && name[4] == 'N')
- global = TRUE;
- break;
- case 6:
- if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
- &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
- ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
- global = TRUE;
- break;
- case 7:
- if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
- && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
- && name[6] == 'T')
- global = TRUE;
- break;
- }
+ *len = name_cursor - *name;
+ return TRUE;
+}
- if (global)
- stash = PL_defstash;
- else if (IN_PERL_COMPILETIME) {
- stash = PL_curstash;
- if (add && (PL_hints & HINT_STRICT_VARS) &&
- sv_type != SVt_PVCV &&
- sv_type != SVt_PVGV &&
- sv_type != SVt_PVFM &&
- sv_type != SVt_PVIO &&
- !(len == 1 && sv_type == SVt_PV &&
- (*name == 'a' || *name == 'b')) )
- {
- gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
- if (!gvp ||
- *gvp == (const GV *)&PL_sv_undef ||
- SvTYPE(*gvp) != SVt_PVGV)
- {
- stash = NULL;
- }
- else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
- (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
- (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
- {
- SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
- /* diag_listed_as: Variable "%s" is not imported%s */
- Perl_ck_warner_d(
- aTHX_ packWARN(WARN_MISC),
- "Variable \"%c%"SVf"\" is not imported",
- sv_type == SVt_PVAV ? '@' :
- sv_type == SVt_PVHV ? '%' : '$',
- SVfARG(namesv));
- if (GvCVu(*gvp))
- Perl_ck_warner_d(
- aTHX_ packWARN(WARN_MISC),
- "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
- );
- stash = NULL;
- }
- }
- }
- else
- stash = CopSTASH(PL_curcop);
- }
- else
- stash = PL_defstash;
+/* Checks if an unqualified name is in the main stash */
+PERL_STATIC_INLINE bool
+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) ) {
+ /* Some "normal" variables are always in main::,
+ * like INC or STDOUT.
+ */
+ switch (len) {
+ case 1:
+ if (*name == '_')
+ return TRUE;
+ break;
+ case 3:
+ if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
+ || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
+ || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
+ return TRUE;
+ break;
+ case 4:
+ if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
+ && name[3] == 'V')
+ return TRUE;
+ break;
+ case 5:
+ if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
+ && name[3] == 'I' && name[4] == 'N')
+ return TRUE;
+ break;
+ case 6:
+ if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
+ &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
+ ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
+ return TRUE;
+ break;
+ case 7:
+ if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
+ && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
+ && name[6] == 'T')
+ return TRUE;
+ break;
+ }
}
+ /* *{""}, or a special variable like $@ */
+ else
+ return TRUE;
+
+ return FALSE;
+}
- /* By this point we should have a stash and a name */
- if (!stash) {
- if (add && !PL_in_clean_all) {
- SV * const namesv = newSVpvn_flags(name, len, is_utf8);
- SV * const err = Perl_mess(aTHX_
- "Global symbol \"%s%"SVf"\" requires explicit package name",
- (sv_type == SVt_PV ? "$"
- : sv_type == SVt_PVAV ? "@"
- : sv_type == SVt_PVHV ? "%"
- : ""), SVfARG(namesv));
- GV *gv;
- SvREFCNT_dec_NN(namesv);
- if (is_utf8)
- SvUTF8_on(err);
- qerror(err);
- gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
- if(!gv) {
- /* symbol table under destruction */
- return NULL;
- }
- stash = GvHV(gv);
- }
- else
- return NULL;
- }
-
- if (!SvREFCNT(stash)) /* symbol table under destruction */
- return NULL;
+/* This function is called if parse_gv_stash_name() failed to
+ * find a stash, or if GV_NOTQUAL or an empty name was passed
+ * to gv_fetchpvn_flags.
+ *
+ * It returns FALSE if the default stash can't be found nor created,
+ * which might happen during global destruction.
+ */
+PERL_STATIC_INLINE bool
+S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
+ const U32 is_utf8, const I32 add,
+ const svtype sv_type)
+{
+ PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
+
+ /* No stash in name, so see how we can default */
- gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
- if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
- if (addmg) gv = (GV *)newSV(0);
- else return NULL;
+ if ( gv_is_in_main(name, len, is_utf8) ) {
+ *stash = PL_defstash;
}
- else gv = *gvp, addmg = 0;
- /* From this point on, addmg means gv has not been inserted in the
- symtab yet. */
-
- if (SvTYPE(gv) == SVt_PVGV) {
- if (add) {
- GvMULTI_on(gv);
- gv_init_svtype(gv, sv_type);
- /* You reach this path once the typeglob has already been created,
- either by the same or a different sigil. If this path didn't
- exist, then (say) referencing $! first, and %! second would
- mean that %! was not handled correctly. */
- if (len == 1 && stash == PL_defstash) {
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
- if (*name == '!')
- require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
- else if (*name == '-' || *name == '+')
- require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
- } else if (sv_type == SVt_PV && *name == '#') {
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
- WARN_SYNTAX),
- "$# is no longer supported");
- }
- if (*name == '*') {
- if (sv_type == SVt_PV)
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
- WARN_SYNTAX),
- "$* is no longer supported, and will become a syntax error");
- else
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "%c* is deprecated, and will become a syntax error",
- sv_type == SVt_PVAV ? '@'
- : sv_type == SVt_PVCV ? '&'
- : sv_type == SVt_PVHV ? '%'
- : '*');
- }
- if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
- switch (*name) {
- case '[':
- require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
- break;
-#ifdef PERL_SAWAMPERSAND
- case '`':
- PL_sawampersand |= SAWAMPERSAND_LEFT;
- (void)GvSVn(gv);
- break;
- case '&':
- PL_sawampersand |= SAWAMPERSAND_MIDDLE;
- (void)GvSVn(gv);
- break;
- case '\'':
- PL_sawampersand |= SAWAMPERSAND_RIGHT;
- (void)GvSVn(gv);
- break;
-#endif
+ else {
+ if (IN_PERL_COMPILETIME) {
+ *stash = PL_curstash;
+ if (add && (PL_hints & HINT_STRICT_VARS) &&
+ sv_type != SVt_PVCV &&
+ sv_type != SVt_PVGV &&
+ sv_type != SVt_PVFM &&
+ sv_type != SVt_PVIO &&
+ !(len == 1 && sv_type == SVt_PV &&
+ (*name == 'a' || *name == 'b')) )
+ {
+ GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -len : len,0);
+ if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
+ SvTYPE(*gvp) != SVt_PVGV)
+ {
+ *stash = NULL;
}
- }
- }
- else if (len == 3 && sv_type == SVt_PVAV
- && strnEQ(name, "ISA", 3)
- && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
- gv_magicalize_isa(gv);
- }
- return gv;
- } else if (no_init) {
- assert(!addmg);
- return gv;
- } else if (no_expand && SvROK(gv)) {
- assert(!addmg);
- return gv;
+ else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
+ (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
+ (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
+ {
+ /* diag_listed_as: Variable "%s" is not imported%s */
+ Perl_ck_warner_d(
+ aTHX_ packWARN(WARN_MISC),
+ "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",
+ UTF8fARG(is_utf8, len, name)
+ );
+ *stash = NULL;
+ }
+ }
+ }
+ else {
+ /* Use the current op's stash */
+ *stash = CopSTASH(PL_curcop);
+ }
}
- /* Adding a new symbol.
- Unless of course there was already something non-GV here, in which case
- we want to behave as if there was always a GV here, containing some sort
- of subroutine.
- Otherwise we run the risk of creating things like GvIO, which can cause
- subtle bugs. eg the one that tripped up SQL::Translator */
+ if (!*stash) {
+ if (add && !PL_in_clean_all) {
+ SV * const err = Perl_mess(aTHX_
+ "Global symbol \"%s%"UTF8f
+ "\" requires explicit package name",
+ (sv_type == SVt_PV ? "$"
+ : sv_type == SVt_PVAV ? "@"
+ : sv_type == SVt_PVHV ? "%"
+ : ""), UTF8fARG(is_utf8, len, name));
+ GV *gv;
+ if (is_utf8)
+ SvUTF8_on(err);
+ qerror(err);
+ /* To maintain the output of errors after the strict exception
+ * above, and to keep compat with older releases, rather than
+ * placing the variables in the pad, we place
+ * them in the <none>:: stash.
+ */
+ gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
+ if (!gv) {
+ /* symbol table under destruction */
+ return FALSE;
+ }
+ *stash = GvHV(gv);
+ }
+ else
+ return FALSE;
+ }
- faking_it = SvOK(gv);
+ if (!SvREFCNT(*stash)) /* symbol table under destruction */
+ return FALSE;
- if (add & GV_ADDWARN)
- Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
- SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
- gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
+ return TRUE;
+}
- if ( isIDFIRST_lazy_if(name, is_utf8)
- && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
- GvMULTI_on(gv) ;
+/* gv_magicalize() is called by gv_fetchpvn_flags when creating
+ * a new GV.
+ * 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.
+ *
+ * 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.
+ */
+PERL_STATIC_INLINE bool
+S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
+ bool addmg, const svtype sv_type)
+{
+ SSize_t paren;
- /* set up magic where warranted */
+ PERL_ARGS_ASSERT_GV_MAGICALIZE;
+
if (stash != PL_defstash) { /* not the main stash */
/* We only have to check for three names here: EXPORT, ISA
and VERSION. All the others apply only to the main stash or to
default:
goto try_core;
}
- goto add_magical_gv;
+ return addmg;
}
try_core:
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
/* Nothing else to do.
The compiler will probably turn the switch statement into a
branch table. Make sure we avoid even that small overhead for
- the common case of lower case variable names. */
+ the common case of lower case variable names. (On EBCDIC
+ platforms, we can't just do:
+ if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
+ because cases like '\027' in the switch statement below are
+ C1 (non-ASCII) controls on those platforms, so the remapping
+ would make them larger than 'V')
+ */
} else
#endif
{
goto ro_magicalize;
break;
case '\015': /* $^MATCH */
- if (strEQ(name2, "ATCH"))
- goto magicalize;
+ if (strEQ(name2, "ATCH")) {
+ paren = RX_BUFF_IDX_CARET_FULLMATCH;
+ goto storeparen;
+ }
+ break;
case '\017': /* $^OPEN */
if (strEQ(name2, "PEN"))
goto magicalize;
break;
case '\020': /* $^PREMATCH $^POSTMATCH */
- if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
- goto magicalize;
+ if (strEQ(name2, "REMATCH")) {
+ paren = RX_BUFF_IDX_CARET_PREMATCH;
+ goto storeparen;
+ }
+ if (strEQ(name2, "OSTMATCH")) {
+ paren = RX_BUFF_IDX_CARET_POSTMATCH;
+ goto storeparen;
+ }
break;
case '\024': /* ${^TAINT} */
if (strEQ(name2, "AINT"))
/* This snippet is taken from is_gv_magical */
const char *end = name + len;
while (--end > name) {
- if (!isDIGIT(*end)) goto add_magical_gv;
+ if (!isDIGIT(*end))
+ return addmg;
}
- goto magicalize;
+ paren = strtoul(name, NULL, 10);
+ goto storeparen;
}
}
}
be case '\0' in this switch statement (ie a default case) */
switch (*name) {
case '&': /* $& */
+ paren = RX_BUFF_IDX_FULLMATCH;
+ goto sawampersand;
case '`': /* $` */
+ paren = RX_BUFF_IDX_PREMATCH;
+ goto sawampersand;
case '\'': /* $' */
+ paren = RX_BUFF_IDX_POSTMATCH;
+ sawampersand:
#ifdef PERL_SAWAMPERSAND
if (!(
sv_type == SVt_PVAV ||
: SAWAMPERSAND_RIGHT;
}
#endif
- goto magicalize;
+ goto storeparen;
+ case '1': /* $1 */
+ case '2': /* $2 */
+ case '3': /* $3 */
+ case '4': /* $4 */
+ case '5': /* $5 */
+ case '6': /* $6 */
+ case '7': /* $7 */
+ case '8': /* $8 */
+ case '9': /* $9 */
+ paren = *name - '0';
+
+ storeparen:
+ /* Flag the capture variables with a NULL mg_ptr
+ Use mg_len for the array index to lookup. */
+ sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
+ break;
case ':': /* $: */
sv_setpv(GvSVn(gv),PL_chopset);
/* magicalization must be done before require_tie_mod is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
{
- if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
- addmg = 0;
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+ addmg = FALSE;
}
break;
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
{
- if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
- addmg = 0;
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+ addmg = FALSE;
}
break;
}
case '*': /* $* */
- if (sv_type == SVt_PV)
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "$* is no longer supported, and will become a syntax error");
- else {
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "%c* is deprecated, and will become a syntax error",
- sv_type == SVt_PVAV ? '@'
- : sv_type == SVt_PVCV ? '&'
- : sv_type == SVt_PVHV ? '%'
- : '*');
- }
- break;
case '#': /* $# */
if (sv_type == SVt_PV)
+ /* diag_listed_as: $* is no longer supported */
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "$# is no longer supported");
+ "$%c is no longer supported", *name);
break;
case '\010': /* $^H */
{
case '[': /* $[ */
if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
&& FEATURE_ARYBASE_IS_ENABLED) {
- if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
- addmg = 0;
+ addmg = FALSE;
}
else goto magicalize;
break;
SvREADONLY_on(GvSVn(gv));
/* FALL THROUGH */
case '0': /* $0 */
- case '1': /* $1 */
- case '2': /* $2 */
- case '3': /* $3 */
- case '4': /* $4 */
- case '5': /* $5 */
- case '6': /* $6 */
- case '7': /* $7 */
- case '8': /* $8 */
- case '9': /* $9 */
case '^': /* $^ */
case '~': /* $~ */
case '=': /* $= */
break;
}
}
- add_magical_gv:
- if (addmg) {
- if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
- GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
- ))
- (void)hv_store(stash,name,len,(SV *)gv,0);
- else SvREFCNT_dec_NN(gv), gv = NULL;
+
+ return addmg;
+}
+
+/* This function is called when the stash already holds the GV of the magic
+ * variable we're looking for, but we need to check that it has the correct
+ * kind of magic. For example, if someone first uses $! and then %!, the
+ * latter would end up here, and we add the Errno tie to the HASH slot of
+ * the *! glob.
+ */
+PERL_STATIC_INLINE void
+S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
+{
+ PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
+
+ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
+ if (*name == '!')
+ require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+ else if (*name == '-' || *name == '+')
+ require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+ } else if (sv_type == SVt_PV) {
+ if (*name == '*' || *name == '#') {
+ /* diag_listed_as: $* is no longer supported */
+ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
+ WARN_SYNTAX),
+ "$%c is no longer supported", *name);
+ }
+ }
+ if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
+ switch (*name) {
+ case '[':
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ break;
+#ifdef PERL_SAWAMPERSAND
+ case '`':
+ PL_sawampersand |= SAWAMPERSAND_LEFT;
+ (void)GvSVn(gv);
+ break;
+ case '&':
+ PL_sawampersand |= SAWAMPERSAND_MIDDLE;
+ (void)GvSVn(gv);
+ break;
+ case '\'':
+ PL_sawampersand |= SAWAMPERSAND_RIGHT;
+ (void)GvSVn(gv);
+ break;
+#endif
+ }
+ }
+}
+
+GV *
+Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
+ const svtype sv_type)
+{
+ dVAR;
+ const char *name = nambeg;
+ GV *gv = NULL;
+ GV**gvp;
+ STRLEN len;
+ HV *stash = NULL;
+ const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
+ const I32 no_expand = flags & GV_NOEXPAND;
+ const I32 add = flags & ~GV_NOADD_MASK;
+ const U32 is_utf8 = flags & SVf_UTF8;
+ bool addmg = cBOOL(flags & GV_ADDMG);
+ const char *const name_end = nambeg + full_len;
+ U32 faking_it;
+
+ PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
+
+ /* If we have GV_NOTQUAL, the caller promised that
+ * there is no stash, so we can skip the check.
+ * Similarly if full_len is 0, since then we're
+ * dealing with something like *{""} or ""->foo()
+ */
+ if ((flags & GV_NOTQUAL) || !full_len) {
+ len = full_len;
+ }
+ else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
+ if (name == name_end) return gv;
+ }
+ else {
+ return NULL;
+ }
+
+ if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
+ return NULL;
+ }
+
+ /* By this point we should have a stash and a name */
+ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
+ if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
+ if (addmg) gv = (GV *)newSV(0);
+ else return NULL;
+ }
+ else gv = *gvp, addmg = 0;
+ /* From this point on, addmg means gv has not been inserted in the
+ symtab yet. */
+
+ if (SvTYPE(gv) == SVt_PVGV) {
+ /* The GV already exists, so return it, but check if we need to do
+ * anything else with it before that.
+ */
+ if (add) {
+ /* This is the heuristic that handles if a variable triggers the
+ * 'used only once' warning. If there's already a GV in the stash
+ * with this name, then we assume that the variable has been used
+ * before and turn its MULTI flag on.
+ * It's a heuristic because it can easily be "tricked", like with
+ * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
+ * not warning about $main::foo being used just once
+ */
+ GvMULTI_on(gv);
+ gv_init_svtype(gv, sv_type);
+ /* You reach this path once the typeglob has already been created,
+ either by the same or a different sigil. If this path didn't
+ exist, then (say) referencing $! first, and %! second would
+ mean that %! was not handled correctly. */
+ if (len == 1 && stash == PL_defstash) {
+ maybe_multimagic_gv(gv, name, sv_type);
+ }
+ else if (len == 3 && sv_type == SVt_PVAV
+ && strnEQ(name, "ISA", 3)
+ && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
+ gv_magicalize_isa(gv);
+ }
+ return gv;
+ } else if (no_init) {
+ assert(!addmg);
+ return gv;
+ }
+ /* If GV_NOEXPAND is true and what we got off the stash is a ref,
+ * don't expand it to a glob. This is an optimization so that things
+ * copying constants over, like Exporter, don't have to be rewritten
+ * to take into account that you can store more than just globs in
+ * stashes.
+ */
+ else if (no_expand && SvROK(gv)) {
+ assert(!addmg);
+ return gv;
+ }
+
+ /* Adding a new symbol.
+ Unless of course there was already something non-GV here, in which case
+ we want to behave as if there was always a GV here, containing some sort
+ of subroutine.
+ Otherwise we run the risk of creating things like GvIO, which can cause
+ subtle bugs. eg the one that tripped up SQL::Translator */
+
+ faking_it = SvOK(gv);
+
+ if (add & GV_ADDWARN)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+ "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) )
+ GvMULTI_on(gv) ;
+
+ /* First, store the gv in the symtab if we're adding magic,
+ * but only for non-empty GVs
+ */
+#define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
+ || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
+
+ if ( addmg && !GvEMPTY(gv) ) {
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ }
+
+ /* set up magic where warranted */
+ if ( gv_magicalize(gv, stash, name, len, addmg, 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
+ * stored in the symtab.
+ */
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ }
+ else {
+ /* Most likely the temporary GV created above */
+ SvREFCNT_dec_NN(gv);
+ gv = NULL;
+ }
+ }
}
+
if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
return gv;
}
}
void
-Perl_gv_check(pTHX_ const HV *stash)
+Perl_gv_check(pTHX_ HV *stash)
{
dVAR;
I32 i;
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
+ /* SvIsCOW is unused on HVs, so we can use it to mark stashes we
+ are currently searching through recursively. */
+ SvIsCOW_on(stash);
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
GV *gv;
HV *hv;
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
{
- if (hv != PL_defstash && hv != stash)
+ if (hv != PL_defstash && hv != stash && !SvIsCOW(hv))
gv_check(hv); /* nested package */
}
else if ( *HeKEY(entry) != '_'
HEKfARG(GvNAME_HEK(gv)));
}
}
+ SvIsCOW_off(stash);
}
}
{
dVAR;
PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
+ assert(!(flags & ~SVf_UTF8));
- return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
- SVfARG(newSVpvn_flags(pack, strlen(pack),
- SVs_TEMP | flags)),
+ return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
+ UTF8fARG(flags, strlen(pack), pack),
(long)PL_gensym++),
GV_ADD, SVt_PVGV);
}
HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
*gvp == (SV*)gv) {
SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
+ const bool imported = !!GvIMPORTED_CV(gv);
SvREFCNT(gv) = 0;
sv_clear((SV*)gv);
SvREFCNT(gv) = 1;
- SvFLAGS(gv) = SVt_IV|SVf_ROK;
+ SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
STRUCT_OFFSET(XPVIV, xiv_iv));
SvRV_set(gv, value);
https://perl5.git.perl.org / perl5.git / blobdiff