}
if (!*where)
+ {
*where = newSV_type(type);
- if (type == SVt_PVAV && GvNAMELEN(gv) == 3
- && strnEQ(GvNAME(gv), "ISA", 3))
- sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
+ if (type == SVt_PVAV && GvNAMELEN(gv) == 3
+ && strnEQ(GvNAME(gv), "ISA", 3))
+ sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
+ }
return gv;
}
gp->gp_sv = newSV(0);
#endif
- /* PL_curcop should never be null here. */
- assert(PL_curcop);
- /* But for non-debugging builds play it safe */
+ /* 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
return TRUE;
}
-/* 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.
- */
+/* Checks if an unqualified name is in the main stash */
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)
+S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
{
- PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
+ PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
- /* No stash in name, so see how we can default */
-
/* If it's an alphanumeric variable */
- if (len && isIDFIRST_lazy_if(name, is_utf8)) {
- bool global = FALSE;
-
+ 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 == '_')
- global = TRUE;
+ 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'))
- global = TRUE;
+ return TRUE;
break;
case 4:
if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
&& name[3] == 'V')
- global = TRUE;
+ return TRUE;
break;
case 5:
if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
&& name[3] == 'I' && name[4] == 'N')
- global = TRUE;
+ 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')))
- global = TRUE;
+ 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')
- global = TRUE;
+ return TRUE;
break;
}
+ }
+ /* *{""}, or a special variable like $@ */
+ else
+ return TRUE;
+
+ return FALSE;
+}
+
+
+/* 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 */
- if (global)
- *stash = PL_defstash;
- else if (IN_PERL_COMPILETIME) {
+ if ( gv_is_in_main(name, len, is_utf8) ) {
+ *stash = PL_defstash;
+ }
+ else {
+ if (IN_PERL_COMPILETIME) {
*stash = PL_curstash;
if (add && (PL_hints & HINT_STRICT_VARS) &&
sv_type != SVt_PVCV &&
*stash = CopSTASH(PL_curcop);
}
}
- /* *{""}, or a special variable like $@ */
- else
- *stash = PL_defstash;
if (!*stash) {
if (add && !PL_in_clean_all) {
return TRUE;
}
-/* magicalize_gv() gets called by gv_fetchpvn_flags when creating a new GV */
-PERL_STATIC_INLINE GV*
-S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
+/* 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;
- PERL_ARGS_ASSERT_MAGICALIZE_GV;
+ PERL_ARGS_ASSERT_GV_MAGICALIZE;
if (stash != PL_defstash) { /* not the main stash */
/* We only have to check for three names here: EXPORT, ISA
default:
goto try_core;
}
- goto add_magical_gv;
+ return addmg;
}
try_core:
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
/* 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;
}
paren = strtoul(name, NULL, 10);
goto storeparen;
/* 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 || 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;
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
+ }
}
-
- return gv;
}
GV *
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);
+ bool addmg = cBOOL(flags & GV_ADDMG);
const char *const name_end = nambeg + full_len;
U32 faking_it;
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,
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) {
- 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
- }
- }
+ maybe_multimagic_gv(gv, name, sv_type);
}
else if (len == 3 && sv_type == SVt_PVAV
&& strnEQ(name, "ISA", 3)
} else if (no_init) {
assert(!addmg);
return gv;
- } else if (no_expand && SvROK(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;
}
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 */
- gv = magicalize_gv(gv, stash, name, len, addmg, sv_type);
+ 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;
!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
return;
+ if (gv == PL_statgv) return;
if (SvMAGICAL(gv)) {
MAGIC *mg;
/* only backref magic is allowed */
https://perl5.git.perl.org / perl5.git / blobdiff