From 070dc47562b0f958a4767d69f47c6cf47cb7e230 Mon Sep 17 00:00:00 2001 From: Brian Fraser Date: Tue, 21 May 2013 11:32:45 -0300 Subject: [PATCH] gv.c, gv_fetchpvn_flags: Split another chunk of magic-checking code. This bit is called when a GV already exists, but it's name is length-one and it's on the main:: stash, so it might have multiple kinds of magic, like $! and %!, or @+ and %+. --- embed.fnc | 1 + embed.h | 1 + gv.c | 82 +++++++++++++++++++++++++++++++++++++-------------------------- proto.h | 6 +++++ 4 files changed, 56 insertions(+), 34 deletions(-) diff --git a/embed.fnc b/embed.fnc index de80406..a09fce9 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1787,6 +1787,7 @@ s |bool|find_default_stash|NN HV **stash|NN const char *name \ s |GV*|magicalize_gv|NN GV *gv|NN HV *stash|NN const char *name \ |STRLEN len|bool addmg \ |svtype sv_type +s |void|maybe_multimagic_gv|NN GV *gv|NN const char *name|const svtype sv_type s |HV* |require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \ |NN const char *methpv|const U32 flags #endif diff --git a/embed.h b/embed.h index da06534..23cd8c5 100644 --- a/embed.h +++ b/embed.h @@ -1382,6 +1382,7 @@ #define gv_init_svtype(a,b) S_gv_init_svtype(aTHX_ a,b) #define gv_magicalize_isa(a) S_gv_magicalize_isa(aTHX_ a) #define magicalize_gv(a,b,c,d,e,f) S_magicalize_gv(aTHX_ a,b,c,d,e,f) +#define maybe_multimagic_gv(a,b,c) S_maybe_multimagic_gv(aTHX_ a,b,c) #define parse_gv_stash_name(a,b,c,d,e,f,g,h) S_parse_gv_stash_name(aTHX_ a,b,c,d,e,f,g,h) #define require_tie_mod(a,b,c,d,e) S_require_tie_mod(aTHX_ a,b,c,d,e) # endif diff --git a/gv.c b/gv.c index 49e8830..29bf398 100644 --- a/gv.c +++ b/gv.c @@ -2008,6 +2008,53 @@ S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, return gv; } +/* 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) @@ -2077,40 +2124,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 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) diff --git a/proto.h b/proto.h index be3a9fa..4cb3e47 100644 --- a/proto.h +++ b/proto.h @@ -5741,6 +5741,12 @@ STATIC GV* S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len #define PERL_ARGS_ASSERT_MAGICALIZE_GV \ assert(gv); assert(stash); assert(name) +STATIC void S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV \ + assert(gv); assert(name) + STATIC 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) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) -- 1.8.3.1