From: Brian Fraser Date: Tue, 9 Apr 2013 08:28:18 +0000 (-0300) Subject: gv.c: Move the code that magicalizes new globs into magicalize_gv(). X-Git-Tag: upstream/5.20.0~1927^2~6 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=71c35c050edbde3b10f7b0ec3be6dc532979ff36;p=platform%2Fupstream%2Fperl.git gv.c: Move the code that magicalizes new globs into magicalize_gv(). --- diff --git a/embed.fnc b/embed.fnc index 780c4f9..de80406 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1784,6 +1784,9 @@ s |bool|parse_gv_stash_name|NN HV **stash|NN GV **gv \ s |bool|find_default_stash|NN HV **stash|NN const char *name \ |STRLEN len|const U32 is_utf8|const I32 add \ |svtype sv_type +s |GV*|magicalize_gv|NN GV *gv|NN HV *stash|NN const char *name \ + |STRLEN len|bool addmg \ + |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 ddd6645..da06534 100644 --- a/embed.h +++ b/embed.h @@ -1381,6 +1381,7 @@ #define find_default_stash(a,b,c,d,e,f) S_find_default_stash(aTHX_ a,b,c,d,e,f) #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 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 94e6474..b0bcd76 100644 --- a/gv.c +++ b/gv.c @@ -1631,134 +1631,15 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, return TRUE; } -GV * -Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, - const svtype sv_type) +/* 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, + bool addmg, const svtype sv_type) { - dVAR; - const char *name = nambeg; - GV *gv = NULL; - GV**gvp; - STRLEN len; - HV *stash = NULL; - 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 U32 is_utf8 = flags & SVf_UTF8; - bool addmg = !!(flags & GV_ADDMG); - const char *const name_end = nambeg + full_len; - U32 faking_it; SSize_t paren; - PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; - - /* If we have GV_NOTQUAL, the caller promised that - * there is no stash, so we can skip the check. - * Similarly if full_len is 0, since then we're - * dealing with something like *{""} or ""->foo() - */ - if ((flags & GV_NOTQUAL) || !full_len) { - len = full_len; - } - else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) { - if (name == name_end) return gv; - } - else { - return NULL; - } - - if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) { - return NULL; - } + PERL_ARGS_ASSERT_MAGICALIZE_GV; - /* By this point we should have a stash and a name */ - gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add); - if (!gvp || *gvp == (const GV *)&PL_sv_undef) { - if (addmg) gv = (GV *)newSV(0); - else return NULL; - } - else gv = *gvp, addmg = 0; - /* From this point on, addmg means gv has not been inserted in the - symtab yet. */ - - if (SvTYPE(gv) == SVt_PVGV) { - if (add) { - GvMULTI_on(gv); - gv_init_svtype(gv, sv_type); - /* You reach this path once the typeglob has already been created, - either by the same or a different sigil. If this path didn't - 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 - } - } - } - else if (len == 3 && sv_type == SVt_PVAV - && strnEQ(name, "ISA", 3) - && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) - gv_magicalize_isa(gv); - } - return gv; - } else if (no_init) { - assert(!addmg); - return gv; - } else if (no_expand && SvROK(gv)) { - assert(!addmg); - return gv; - } - - /* Adding a new symbol. - Unless of course there was already something non-GV here, in which case - we want to behave as if there was always a GV here, containing some sort - of subroutine. - Otherwise we run the risk of creating things like GvIO, which can cause - subtle bugs. eg the one that tripped up SQL::Translator */ - - faking_it = SvOK(gv); - - if (add & GV_ADDWARN) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Had to create %"UTF8f" unexpectedly", - UTF8fARG(is_utf8, name_end-nambeg, nambeg)); - gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); - - if ( isIDFIRST_lazy_if(name, is_utf8) - && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) - GvMULTI_on(gv) ; - - /* set up magic where warranted */ if (stash != PL_defstash) { /* not the main stash */ /* We only have to check for three names here: EXPORT, ISA and VERSION. All the others apply only to the main stash or to @@ -2118,6 +1999,139 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, (void)hv_store(stash,name,len,(SV *)gv,0); else SvREFCNT_dec_NN(gv), gv = NULL; } + + return gv; +} + +GV * +Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, + const svtype sv_type) +{ + dVAR; + const char *name = nambeg; + GV *gv = NULL; + GV**gvp; + STRLEN len; + HV *stash = NULL; + 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 U32 is_utf8 = flags & SVf_UTF8; + bool addmg = !!(flags & GV_ADDMG); + const char *const name_end = nambeg + full_len; + U32 faking_it; + + PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; + + /* If we have GV_NOTQUAL, the caller promised that + * there is no stash, so we can skip the check. + * Similarly if full_len is 0, since then we're + * dealing with something like *{""} or ""->foo() + */ + if ((flags & GV_NOTQUAL) || !full_len) { + len = full_len; + } + else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) { + if (name == name_end) return gv; + } + else { + return NULL; + } + + if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) { + return NULL; + } + + /* By this point we should have a stash and a name */ + gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add); + if (!gvp || *gvp == (const GV *)&PL_sv_undef) { + if (addmg) gv = (GV *)newSV(0); + else return NULL; + } + else gv = *gvp, addmg = 0; + /* From this point on, addmg means gv has not been inserted in the + symtab yet. */ + + if (SvTYPE(gv) == SVt_PVGV) { + if (add) { + GvMULTI_on(gv); + gv_init_svtype(gv, sv_type); + /* You reach this path once the typeglob has already been created, + either by the same or a different sigil. If this path didn't + 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 + } + } + } + else if (len == 3 && sv_type == SVt_PVAV + && strnEQ(name, "ISA", 3) + && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) + gv_magicalize_isa(gv); + } + return gv; + } else if (no_init) { + assert(!addmg); + return gv; + } else if (no_expand && SvROK(gv)) { + assert(!addmg); + return gv; + } + + /* Adding a new symbol. + Unless of course there was already something non-GV here, in which case + we want to behave as if there was always a GV here, containing some sort + of subroutine. + Otherwise we run the risk of creating things like GvIO, which can cause + subtle bugs. eg the one that tripped up SQL::Translator */ + + faking_it = SvOK(gv); + + if (add & GV_ADDWARN) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Had to create %"UTF8f" unexpectedly", + UTF8fARG(is_utf8, name_end-nambeg, nambeg)); + gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); + + if ( isIDFIRST_lazy_if(name, is_utf8) + && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) + GvMULTI_on(gv) ; + + /* set up magic where warranted */ + gv = magicalize_gv(gv, stash, name, len, addmg, sv_type); + if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); return gv; } diff --git a/proto.h b/proto.h index e77c66d..be3a9fa 100644 --- a/proto.h +++ b/proto.h @@ -5734,6 +5734,13 @@ STATIC void S_gv_magicalize_isa(pTHX_ GV *gv) #define PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA \ assert(gv) +STATIC GV* S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, bool addmg, svtype sv_type) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_MAGICALIZE_GV \ + assert(gv); assert(stash); 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)