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.

1 files changed, 21 insertions, 148 deletions

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)
 {