diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rw-r--r-- | gv.c | 72 | ||||
| -rw-r--r-- | proto.h | 11 |
4 files changed, 61 insertions, 28 deletions
@@ -1501,6 +1501,8 @@ sR |I32 |do_trans_complex_utf8 |NN SV * const sv #if defined(PERL_IN_GV_C) s |void |gv_init_sv |NN GV *gv|const svtype sv_type +s |void |gv_magicalize_isa |NN GV *gv|NN const char *nambeg|I32 add +s |void |gv_magicalize_overload |NN GV *gv s |HV* |gv_get_super_pkg|NN const char* name|I32 namelen s |HV* |require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \ |NN const char *methpv|const U32 flags @@ -1250,6 +1250,8 @@ #if defined(PERL_IN_GV_C) #ifdef PERL_CORE #define gv_init_sv S_gv_init_sv +#define gv_magicalize_isa S_gv_magicalize_isa +#define gv_magicalize_overload S_gv_magicalize_overload #define gv_get_super_pkg S_gv_get_super_pkg #define require_tie_mod S_require_tie_mod #endif @@ -3699,6 +3701,8 @@ #if defined(PERL_IN_GV_C) #ifdef PERL_CORE #define gv_init_sv(a,b) S_gv_init_sv(aTHX_ a,b) +#define gv_magicalize_isa(a,b,c) S_gv_magicalize_isa(aTHX_ a,b,c) +#define gv_magicalize_overload(a) S_gv_magicalize_overload(aTHX_ a) #define gv_get_super_pkg(a,b) S_gv_get_super_pkg(aTHX_ a,b) #define require_tie_mod(a,b,c,d,e) S_require_tie_mod(aTHX_ a,b,c,d,e) #endif @@ -963,6 +963,46 @@ Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); } +STATIC void +S_gv_magicalize_isa(GV *gv, const char *nambeg, I32 add) +{ + AV* av; + + PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA; + + av = GvAVn(gv); + GvMULTI_on(gv); + sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, + NULL, 0); + /* NOTE: No support for tied ISA */ + if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") + && AvFILLp(av) == -1) + { + av_push(av, newSVpvs("NDBM_File")); + gv_stashpvs("NDBM_File", GV_ADD); + av_push(av, newSVpvs("DB_File")); + gv_stashpvs("DB_File", GV_ADD); + av_push(av, newSVpvs("GDBM_File")); + gv_stashpvs("GDBM_File", GV_ADD); + av_push(av, newSVpvs("SDBM_File")); + gv_stashpvs("SDBM_File", GV_ADD); + av_push(av, newSVpvs("ODBM_File")); + gv_stashpvs("ODBM_File", GV_ADD); + } +} + +STATIC void +S_gv_magicalize_overload(GV *gv) +{ + HV* hv; + + PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD; + + hv = GvHVn(gv); + GvMULTI_on(gv); + hv_magic(hv, NULL, PERL_MAGIC_overload); +} + GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const svtype sv_type) @@ -1216,35 +1256,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case 'I': if (strEQ(name2, "SA")) - magicalize_isa: { - AV* const av = GvAVn(gv); - GvMULTI_on(gv); - sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, - NULL, 0); - /* NOTE: No support for tied ISA */ - if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") - && AvFILLp(av) == -1) - { - av_push(av, newSVpvs("NDBM_File")); - gv_stashpvs("NDBM_File", GV_ADD); - av_push(av, newSVpvs("DB_File")); - gv_stashpvs("DB_File", GV_ADD); - av_push(av, newSVpvs("GDBM_File")); - gv_stashpvs("GDBM_File", GV_ADD); - av_push(av, newSVpvs("SDBM_File")); - gv_stashpvs("SDBM_File", GV_ADD); - av_push(av, newSVpvs("ODBM_File")); - gv_stashpvs("ODBM_File", GV_ADD); - } - } + gv_magicalize_isa(gv, nambeg, add); break; case 'O': if (strEQ(name2, "VERLOAD")) - magicalize_overload: { - HV* const hv = GvHVn(gv); - GvMULTI_on(gv); - hv_magic(hv, NULL, PERL_MAGIC_overload); - } + gv_magicalize_overload(gv); break; case 'V': if (strEQ(name2, "ERSION")) @@ -1280,12 +1296,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case 'I': if (strEQ(name2, "SA")) { - goto magicalize_isa; + gv_magicalize_isa(gv, nambeg, add); } break; case 'O': if (strEQ(name2, "VERLOAD")) { - goto magicalize_overload; + gv_magicalize_overload(gv); } break; case 'S': @@ -4503,6 +4503,17 @@ STATIC void S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type) #define PERL_ARGS_ASSERT_GV_INIT_SV \ assert(gv) +STATIC void S_gv_magicalize_isa(pTHX_ GV *gv, const char *nambeg, I32 add) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA \ + assert(gv); assert(nambeg) + +STATIC void S_gv_magicalize_overload(pTHX_ GV *gv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD \ + assert(gv) + STATIC HV* S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_GET_SUPER_PKG \ |