Eliminate is_gv_magical_sv

This resolves perl bug #97978.

Many built-in variables, like $], are actually created on the fly
when first accessed.  Perl likes to pretend that these variables have
always existed, so it autovivifies the *] glob even in rvalue context
(e.g., defined *{"]"}, close "]").

The list of variables that were autovivified was maintained separ-
ately (in is_gv_magical_sv) from the code that actually creates
them (gv_fetchpvn_flags).  ‘Maintained’ is not actually precise: it
*wasn’t* being maintained, and there were new variables that never
got added to is_gv_magical_sv and one deleted variable that was
never removed.

There are only two pieces of code that call is_gv_magical_sv, both in
pp.c: S_rv2gv (called by *{} and also the implicit *{} that functions
like close() provide) and Perl_softrefxv (called by ${}, @{}, %{}).

In both cases, the glob is immediately autovivified if
is_gv_magical_sv returns true.

So this commit eliminates the extra maintenance burden by extirpat-
ing is_gv_magical_sv altogether, and replacing it with a new flag to
gv_fetchpvn_flags, GvADDMG, which will autovivify a glob *if* it’s a
magical one.

It does make defined(*{"frobbly"}) slightly slower, in that it creates
a temporary glob and then frees it when it sees nothing magical has
been done with it.  But this case is rare enough it should not matter.
At least I got rid of the bugginess.

8 files changed, 43 insertions, 179 deletions

diff --git a/embed.fnc b/embed.fnc
index be472cecde..106c6c7df6 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2315,8 +2315,6 @@ np	|void	|my_swabn	|NN void* ptr|int n
 
 Ap	|GV*	|gv_fetchpvn_flags|NN const char* name|STRLEN len|I32 flags|const svtype sv_type
 Ap	|GV*	|gv_fetchsv|NN SV *name|I32 flags|const svtype sv_type
-: Only used in pp.c
-dpR	|bool	|is_gv_magical_sv|NN SV *const name_sv|U32 flags
 
 ApR	|bool	|stashpv_hvname_match|NN const COP *c|NN const HV *hv
 
diff --git a/embed.h b/embed.h
index c7659310e1..4ac70e747c 100644
--- a/embed.h
+++ b/embed.h
@@ -1049,7 +1049,6 @@
 #define intro_my()		Perl_intro_my(aTHX)
 #define invert(a)		Perl_invert(aTHX_ a)
 #define io_close(a,b)		Perl_io_close(aTHX_ a,b)
-#define is_gv_magical_sv(a,b)	Perl_is_gv_magical_sv(aTHX_ a,b)
 #define jmaybe(a)		Perl_jmaybe(aTHX_ a)
 #define keyword(a,b,c)		Perl_keyword(aTHX_ a,b,c)
 #define list(a)			Perl_list(aTHX_ a)
diff --git a/gv.c b/gv.c
index 01d00d88da..d2d2ed2dde 100644
--- a/gv.c
+++ b/gv.c
@@ -1050,6 +1050,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     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 bool addmg = !!(flags & GV_ADDMG);
     const char *const name_end = nambeg + full_len;
     const char *const name_em1 = name_end - 1;
     U32 faking_it;
@@ -1253,9 +1254,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	return NULL;
 
     gvp = (GV**)hv_fetch(stash,name,len,add);
-    if (!gvp || *gvp == (const GV *)&PL_sv_undef)
-	return NULL;
-    gv = *gvp;
+    if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
+	if (addmg) gv = (GV *)newSV(0);
+	else return NULL;
+    }
+    else gv = *gvp;
     if (SvTYPE(gv) == SVt_PVGV) {
 	if (add) {
 	    GvMULTI_on(gv);
@@ -1274,8 +1277,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	}
 	return gv;
     } else if (no_init) {
+	assert(!addmg);
 	return gv;
     } else if (no_expand && SvROK(gv)) {
+	assert(!addmg);
 	return gv;
     }
 
@@ -1291,7 +1296,6 @@ 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 %s unexpectedly", nambeg);
     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
-    gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
 
     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 			                    : (PL_dowarn & G_WARN_ON ) ) )
@@ -1324,7 +1328,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    default:
 		goto try_core;
 	    }
-	    return gv;
+	    goto add_magical_gv;
 	}
       try_core:
 	if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
@@ -1341,7 +1345,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    yy_parser *oldparser;
 	    I32 oldsavestack_ix;
 
-	    if (code >= 0) return gv; /* not overridable */
+	    if (code >= 0) goto add_magical_gv; /* not overridable */
 	    switch (-code) {
 	     /* no support for \&CORE::infix;
 	        no support for funcs that take labels, as their parsing is
@@ -1350,7 +1354,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    case KEY_eq: case KEY_ge:
 	    case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
 	    case KEY_or: case KEY_x: case KEY_xor:
-		return gv;
+		goto add_magical_gv;
 	    case KEY_chdir:
 	    case KEY_chomp: case KEY_chop:
 	    case KEY_each: case KEY_eof: case KEY_exec:
@@ -1552,7 +1556,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		/* This snippet is taken from is_gv_magical */
 		const char *end = name + len;
 		while (--end > name) {
-		    if (!isDIGIT(*end))	return gv;
+		    if (!isDIGIT(*end))	goto add_magical_gv;
 		}
 		goto magicalize;
 	    }
@@ -1699,6 +1703,15 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	break;
 	}
     }
+  add_magical_gv:
+    if (addmg) {
+	if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
+	     GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
+	   ))
+	    hv_store(stash,name,len,(SV *)gv,0);
+	else SvREFCNT_dec(gv), gv = NULL;
+    }
+    if (gv) gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
     return gv;
 }
 
@@ -2651,146 +2664,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
   }
 }
 
-/*
-=for apidoc is_gv_magical_sv
-
-Returns C<TRUE> if given the name of a magical GV.  Any get-magic that
-C<name_sv> has is ignored.
-
-Currently only useful internally when determining if a GV should be
-created even in rvalue contexts.
-
-C<flags> is not used at present but available for future extension to
-allow selecting particular classes of magical variable.
-
-=cut
-*/
-
-bool
-Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
-{
-    STRLEN len;
-    const char *const name = SvPV_nomg_const(name_sv, len);
-
-    PERL_UNUSED_ARG(flags);
-    PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
-
-    if (len > 1) {
-	const char * const name1 = name + 1;
-	switch (*name) {
-	case 'I':
-	    if (len == 3 && name[1] == 'S' && name[2] == 'A')
-		goto yes;
-	    break;
-	case 'O':
-	    if (len == 8 && strEQ(name1, "VERLOAD"))
-		goto yes;
-	    break;
-	case 'S':
-	    if (len == 3 && name[1] == 'I' && name[2] == 'G')
-		goto yes;
-	    break;
-	    /* Using ${^...} variables is likely to be sufficiently rare that
-	       it seems sensible to avoid the space hit of also checking the
-	       length.  */
-	case '\017':   /* ${^OPEN} */
-	    if (strEQ(name1, "PEN"))
-		goto yes;
-	    break;
-	case '\024':   /* ${^TAINT} */
-	    if (strEQ(name1, "AINT"))
-		goto yes;
-	    break;
-	case '\025':	/* ${^UNICODE} */
-	    if (strEQ(name1, "NICODE"))
-		goto yes;
-	    if (strEQ(name1, "TF8LOCALE"))
-		goto yes;
-	    break;
-	case '\027':   /* ${^WARNING_BITS} */
-	    if (strEQ(name1, "ARNING_BITS"))
-		goto yes;
-	    break;
-	case '1':
-	case '2':
-	case '3':
-	case '4':
-	case '5':
-	case '6':
-	case '7':
-	case '8':
-	case '9':
-	{
-	    const char *end = name + len;
-	    while (--end > name) {
-		if (!isDIGIT(*end))
-		    return FALSE;
-	    }
-	    goto yes;
-	}
-	}
-    } else {
-	/* Because we're already assuming that name is NUL terminated
-	   below, we can treat an empty name as "\0"  */
-	switch (*name) {
-	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 '\016':   /* $^N */
-	case '\017':   /* $^O */
-	case '\020':   /* $^P */
-	case '\023':   /* $^S */
-	case '\024':   /* $^T */
-	case '\026':   /* $^V */
-	case '\027':   /* $^W */
-	case '1':
-	case '2':
-	case '3':
-	case '4':
-	case '5':
-	case '6':
-	case '7':
-	case '8':
-	case '9':
-	yes:
-	    return TRUE;
-	default:
-	    break;
-	}
-    }
-    return FALSE;
-}
-
 void
 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
 {
diff --git a/gv.h b/gv.h
index a70a9060af..b9d04e6b58 100644
--- a/gv.h
+++ b/gv.h
@@ -213,13 +213,17 @@ Return the SV from the GV.
 				   package (so skip checks for :: and ')  */
 #define GV_AUTOLOAD	0x100	/* gv_fetchmethod_flags() should AUTOLOAD  */
 #define GV_CROAK	0x200	/* gv_fetchmethod_flags() should croak  */
+#define GV_ADDMG	0x400	/* add if magical */
 
 /*      SVf_UTF8 (more accurately the return value from SvUTF8) is also valid
 	as a flag to gv_fetch_pvn_flags, so ensure it lies outside this range.
 */
 
-#define GV_NOADD_MASK	(SVf_UTF8|GV_NOADD_NOINIT|GV_NOEXPAND|GV_NOTQUAL)
-/* The bit flags that don't cause gv_fetchpv() to add a symbol if not found */
+#define GV_NOADD_MASK \
+    (SVf_UTF8|GV_NOADD_NOINIT|GV_NOEXPAND|GV_NOTQUAL|GV_ADDMG)
+/* The bit flags that don't cause gv_fetchpv() to add a symbol if not
+   found (with the exception GV_ADDMG, which *might* cause the symbol
+   to be added) */
 
 #define gv_fullname3(sv,gv,prefix) gv_fullname4(sv,gv,prefix,TRUE)
 #define gv_efullname3(sv,gv,prefix) gv_efullname4(sv,gv,prefix,TRUE)
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 650d2e2dac..972135755c 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -388,6 +388,14 @@ variable had not been used yet.  This has been fixed.
 
 =item *
 
+C<defined(${"..."})> used to return true for most built-in defined
+variables, but not others, if they had not been used yet.  Many times that
+new built-in variables have been added in past versions, this construct was
+not taken into account, so this affected C<${^GLOBAL_PHASE}> and
+C<${^UTF8CACHE}>, among others.
+
+=item *
+
 Perl 5.10.0 introduced a similar bug: C<defined(*{"foo"})> where "foo"
 represents the name of a built-in global variable used to return false if
 the variable had never been used before, but only on the I<first> call.
diff --git a/pp.c b/pp.c
index 2d1f7a9d7c..ab933c984b 100644
--- a/pp.c
+++ b/pp.c
@@ -211,17 +211,10 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
 	    {
 		STRLEN len;
 		const char * const nambeg = SvPV_nomg_const(sv, len);
-		SV * const temp = MUTABLE_SV(
-		    gv_fetchpvn_flags(nambeg, len, SvUTF8(sv), SVt_PVGV)
-		);
-		if (!temp
-		    && (!is_gv_magical_sv(sv,0)
-			|| !(sv = MUTABLE_SV(gv_fetchpvn_flags(
-				 nambeg, len, GV_ADD | SvUTF8(sv),
-							SVt_PVGV))))) {
+		if (!(sv = MUTABLE_SV(gv_fetchpvn_flags(
+		           nambeg, len, SvUTF8(sv)|GV_ADDMG, SVt_PVGV
+		   ))))
 		    return &PL_sv_undef;
-		}
-		if (temp) sv = temp;
 	    }
 	    else {
 		if (strict)
@@ -315,14 +308,9 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 	{
 	    STRLEN len;
 	    const char * const nambeg = SvPV_nomg_const(sv, len);
-	    gv = gv_fetchpvn_flags(nambeg, len, SvUTF8(sv), type);
-	    if (!gv
-		&& (!is_gv_magical_sv(sv,0)
-		    || !(gv = gv_fetchpvn_flags(
-		          nambeg, len, GV_ADD|SvUTF8(sv), type
-		        ))
-		   )
-	       )
+	    if (!(gv = gv_fetchpvn_flags(
+	                   nambeg, len, SvUTF8(sv)|GV_ADDMG, type
+	       )))
 		{
 		    **spp = &PL_sv_undef;
 		    return NULL;
diff --git a/proto.h b/proto.h
index 53f2931a68..4c79414f60 100644
--- a/proto.h
+++ b/proto.h
@@ -1520,12 +1520,6 @@ PERL_CALLCONV bool	Perl_is_ascii_string(const U8 *s, STRLEN len)
 #define PERL_ARGS_ASSERT_IS_ASCII_STRING	\
 	assert(s)
 
-PERL_CALLCONV bool	Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
-			__attribute__warn_unused_result__
-			__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV	\
-	assert(name_sv)
-
 PERL_CALLCONV I32	Perl_is_lvalue_sub(pTHX)
 			__attribute__warn_unused_result__;
 
diff --git a/t/op/magic.t b/t/op/magic.t
index d7c17091d0..3969673742 100644
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -18,8 +18,8 @@ BEGIN {
     my %non_mini = map { $_ => 1 } qw(+ -);
     for (qw(
 	SIG ^OPEN ^TAINT ^UNICODE ^UTF8LOCALE ^WARNING_BITS 1 2 3 4 5 6 7 8
-	9 42 & ` ' : ? ! _ - # [ ^ ~ = % . ( ) < > \ / $ | + ; ] ^A ^C ^D
-	^E ^F ^H ^I ^L ^N ^O ^P ^S ^T ^V ^W
+	9 42 & ` ' : ? ! _ - [ ^ ~ = % . ( ) < > \ / $ | + ; ] ^A ^C ^D
+	^E ^F ^H ^I ^L ^N ^O ^P ^S ^T ^V ^W ^UTF8CACHE
     )) {
 	my $v = $_;
 	# avoid using any global vars here: