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.
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
#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)
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;
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);
}
return gv;
} else if (no_init) {
+ assert(!addmg);
return gv;
} else if (no_expand && SvROK(gv)) {
+ assert(!addmg);
return gv;
}
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 ) ) )
default:
goto try_core;
}
- return gv;
+ goto add_magical_gv;
}
try_core:
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
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
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:
/* 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;
}
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;
}
}
}
-/*
-=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)
{
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)
=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.
{
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)
{
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;
#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__;
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:
https://perl5.git.perl.org / perl5.git / commitdiff