diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embed.fnc | 6 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 28 | ||||
| -rw-r--r-- | ext/XS-APItest/t/gv_fetchmeth.t | 36 | ||||
| -rw-r--r-- | gv.c | 63 | ||||
| -rw-r--r-- | gv.h | 1 | ||||
| -rw-r--r-- | proto.h | 18 |
8 files changed, 139 insertions, 18 deletions
@@ -3819,6 +3819,7 @@ ext/XS-APItest/t/exception.t XS::APItest extension ext/XS-APItest/t/fetch_pad_names.t Tests for UTF8 names in pad ext/XS-APItest/t/gotosub.t XS::APItest: tests goto &xsub and hints ext/XS-APItest/t/grok.t XS::APItest: tests for grok* functions +ext/XS-APItest/t/gv_fetchmeth.t XS::APItest: tests for gv_fetchmeth() and variants ext/XS-APItest/t/gv_init.t XS::APItest: tests for gv_init and variants ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs ext/XS-APItest/t/keyword_multiline.t test keyword plugin parsing across lines @@ -437,7 +437,11 @@ Ap |void |gv_efullname4 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|boo Ap |GV* |gv_fetchfile |NN const char* name Ap |GV* |gv_fetchfile_flags|NN const char *const name|const STRLEN len\ |const U32 flags -Apd |GV* |gv_fetchmeth |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level +Apd |GV* |gv_fetchmeth_sv |NULLOK HV* stash|NN SV* namesv|I32 level|U32 flags +Apd |GV* |gv_fetchmeth_pv |NULLOK HV* stash|NN const char* name \ + |I32 level|U32 flags +Apd |GV* |gv_fetchmeth_pvn |NULLOK HV* stash|NN const char* name \ + |STRLEN len|I32 level|U32 flags Apd |GV* |gv_fetchmeth_autoload |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level Apdmb |GV* |gv_fetchmethod |NN HV* stash|NN const char* name Apd |GV* |gv_fetchmethod_autoload|NN HV* stash|NN const char* name \ @@ -169,8 +169,10 @@ #define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d) #define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a) #define gv_fetchfile_flags(a,b,c) Perl_gv_fetchfile_flags(aTHX_ a,b,c) -#define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d) #define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d) +#define gv_fetchmeth_pv(a,b,c,d) Perl_gv_fetchmeth_pv(aTHX_ a,b,c,d) +#define gv_fetchmeth_pvn(a,b,c,d,e) Perl_gv_fetchmeth_pvn(aTHX_ a,b,c,d,e) +#define gv_fetchmeth_sv(a,b,c,d) Perl_gv_fetchmeth_sv(aTHX_ a,b,c,d) #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c) #define gv_fetchmethod_flags(a,b,c) Perl_gv_fetchmethod_flags(aTHX_ a,b,c) #define gv_fetchpv(a,b,c) Perl_gv_fetchpv(aTHX_ a,b,c) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index d555931c49..56c9dd92d5 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1869,6 +1869,34 @@ gv_init_type(namesv, multi, flags, type) XPUSHs( gv ? (SV*)gv : &PL_sv_undef); void +gv_fetchmeth_type(stash, methname, type, level, flags) + HV* stash + SV* methname + int type + I32 level + I32 flags + PREINIT: + STRLEN len; + const char * const name = SvPV_const(methname, len); + GV* gv; + PPCODE: + switch (type) { + case 0: + gv = gv_fetchmeth(stash, name, len, level); + break; + case 1: + gv = gv_fetchmeth_sv(stash, methname, level, flags); + break; + case 2: + gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname)); + break; + case 3: + gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname)); + break; + } + XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef ); + +void eval_sv(sv, flags) SV* sv I32 flags diff --git a/ext/XS-APItest/t/gv_fetchmeth.t b/ext/XS-APItest/t/gv_fetchmeth.t new file mode 100644 index 0000000000..a69e91972f --- /dev/null +++ b/ext/XS-APItest/t/gv_fetchmeth.t @@ -0,0 +1,36 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 25; + +use_ok('XS::APItest'); + +my $level = -1; +my @types = map { 'gv_fetchmeth' . $_ } '', qw( _sv _pv _pvn ); + +sub test { "Sanity check" } + +for my $type ( 0..3 ) { + is *{XS::APItest::gv_fetchmeth_type(\%::, "test", 1, $level, 0)}{CODE}->(), "Sanity check"; +} + +for my $type ( 0..3 ) { + my $meth = "gen$type"; + ok !XS::APItest::gv_fetchmeth_type(\%::, $meth, $type, -1, 0), "With level = -1, $types[$type] returns false"; + ok !$::{$meth}, "...and doesn't vivify the glob."; + + ok !XS::APItest::gv_fetchmeth_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false."; + ok $::{$meth}, "...but does vivify the glob."; +} + +{ + no warnings 'once'; + *method = sub { 1 }; +} + +ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 0, $level, 0), "gv_fetchmeth() is nul-clean"; +ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 1, $level, 0), "gv_fetchmeth_sv() is nul-clean"; +is XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 2, $level, 0), "*main::method", "gv_fetchmeth_pv() is not nul-clean"; +ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 3, $level, 0), "gv_fetchmeth_pvn() is nul-clean"; @@ -555,7 +555,44 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, } /* -=for apidoc gv_fetchmeth +=for apidoc gv_fetchmeth_sv + +Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form +of an SV instead of a string/length pair. + +=cut +*/ + +GV * +Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_GV_FETCHMETH_SV; + namepv = SvPV(namesv, namelen); + if (SvUTF8(namesv)) + flags |= SVf_UTF8; + return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags); +} + +/* +=for apidoc gv_fetchmeth_pv + +Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string +instead of a string/length pair. + +=cut +*/ + +GV * +Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags) +{ + PERL_ARGS_ASSERT_GV_FETCHMETH_PV; + return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags); +} + +/* +=for apidoc gv_fetchmeth_pvn Returns the glob with the given C<name> and a defined subroutine or C<NULL>. The glob lives in the given C<stash>, or in the stashes @@ -566,6 +603,8 @@ side-effect creates a glob with the given C<name> in the given C<stash> which in the case of success contains an alias for the subroutine, and sets up caching info for this glob. +Currently, the only significant value for C<flags> is SVf_UTF8. + This function grants C<"SUPER"> token as a postfix of the stash name. The GV returned from C<gv_fetchmeth> may be a method cache entry, which is not visible to Perl code. So when calling C<call_sv>, you should not use @@ -578,7 +617,7 @@ obtained from the GV with the C<GvCV> macro. /* NOTE: No support for tied ISA */ GV * -Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) +Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) { dVAR; GV** gvp; @@ -595,7 +634,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) STRLEN packlen; U32 topgen_cmp; - PERL_ARGS_ASSERT_GV_FETCHMETH; + PERL_ARGS_ASSERT_GV_FETCHMETH_PVN; /* UNIVERSAL methods should be callable without a stash */ if (!stash) { @@ -709,7 +748,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* Check UNIVERSAL without caching */ if(level == 0 || level == -1) { - candidate = gv_fetchmeth(NULL, name, len, 1); + candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags); if(candidate) { cand_cv = GvCV(candidate); if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { @@ -747,7 +786,7 @@ of the result may be zero. GV * Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { - GV *gv = gv_fetchmeth(stash, name, len, level); + GV *gv = gv_fetchmeth_pvn(stash, name, len, level, 0); PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD; @@ -759,14 +798,14 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) return NULL; - if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) + if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 0))) return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) return NULL; /* Have an autoload */ if (level < 0) /* Cannot do without a stub */ - gv_fetchmeth(stash, name, len, 0); + gv_fetchmeth_pvn(stash, name, len, 0, 0); gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) return NULL; @@ -903,7 +942,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) ostash = stash; } - gv = gv_fetchmeth(stash, name, nend - name, 0); + gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = MUTABLE_GV(&PL_sv_yes); @@ -923,7 +962,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) HV_FETCH_ISEXISTS, NULL, 0) ) { require_pv("IO/File.pm"); - gv = gv_fetchmeth(stash, name, nend - name, 0); + gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0); if (gv) return gv; } @@ -998,7 +1037,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) packname_len = HvNAMELEN_get(stash); } } - if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) + if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 0))) return NULL; cv = GvCV(gv); @@ -2076,7 +2115,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ /* Try to find via inheritance. */ - GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); + GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0); SV * const sv = gv ? GvSV(gv) : NULL; CV* cv; @@ -2112,7 +2151,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (i >= DESTROY_amg) gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0); else /* Autoload taken care of below */ - gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); + gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); cv = 0; if (gv && (cv = GvCV(gv))) { if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){ @@ -238,6 +238,7 @@ Return the SV from the GV. #define gv_fetchmethod(stash, name) gv_fetchmethod_autoload(stash, name, TRUE) #define gv_fetchsv_nomg(n,f,t) gv_fetchsv(n,(f)|GV_NO_SVGMAGIC,t) #define gv_init(gv,stash,name,len,multi) gv_init_pvn(gv,stash,name,len,multi,0) +#define gv_fetchmeth(stash,name, len,level) gv_fetchmeth_pvn(stash, name, len, level, 0) #define gv_AVadd(gv) gv_add_by_type((gv), SVt_PVAV) #define gv_HVadd(gv) gv_add_by_type((gv), SVt_PVHV) @@ -1192,16 +1192,26 @@ PERL_CALLCONV GV* Perl_gv_fetchfile_flags(pTHX_ const char *const name, const ST #define PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS \ assert(name) -PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level) +PERL_CALLCONV GV* Perl_gv_fetchmeth_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level) __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_GV_FETCHMETH \ +#define PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD \ assert(name) -PERL_CALLCONV GV* Perl_gv_fetchmeth_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level) +PERL_CALLCONV GV* Perl_gv_fetchmeth_pv(pTHX_ HV* stash, const char* name, I32 level, U32 flags) __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD \ +#define PERL_ARGS_ASSERT_GV_FETCHMETH_PV \ + assert(name) + +PERL_CALLCONV GV* Perl_gv_fetchmeth_pvn(pTHX_ HV* stash, const char* name, STRLEN len, I32 level, U32 flags) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_GV_FETCHMETH_PVN \ assert(name) +PERL_CALLCONV GV* Perl_gv_fetchmeth_sv(pTHX_ HV* stash, SV* namesv, I32 level, U32 flags) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_GV_FETCHMETH_SV \ + assert(namesv) + /* PERL_CALLCONV GV* Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); */ |