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_autoload.t XS::APItest: tests for gv_fetchmeth_autoload() and variants
+ext/XS-APItest/t/gv_fetchmethod_flags.t XS::APItest: tests for gv_fetchmethod_flags() and variants
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
Apdmb |GV* |gv_fetchmethod |NN HV* stash|NN const char* name
Apd |GV* |gv_fetchmethod_autoload|NN HV* stash|NN const char* name \
|I32 autoload
-ApM |GV* |gv_fetchmethod_flags|NN HV* stash|NN const char* name \
- |U32 flags
+ApM |GV* |gv_fetchmethod_sv_flags|NN HV* stash|NN SV* namesv|U32 flags
+ApM |GV* |gv_fetchmethod_pv_flags|NN HV* stash|NN const char* name \
+ |U32 flags
+ApM |GV* |gv_fetchmethod_pvn_flags|NN HV* stash|NN const char* name \
+ |STRLEN len|U32 flags
Ap |GV* |gv_fetchpv |NN const char *nambeg|I32 add|const svtype sv_type
Ap |void |gv_fullname |NN SV* sv|NN const GV* gv
Apmb |void |gv_fullname3 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix
#define gv_fetchmeth_sv(a,b,c,d) Perl_gv_fetchmeth_sv(aTHX_ a,b,c,d)
#define gv_fetchmeth_sv_autoload(a,b,c,d) Perl_gv_fetchmeth_sv_autoload(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_fetchmethod_pv_flags(a,b,c) Perl_gv_fetchmethod_pv_flags(aTHX_ a,b,c)
+#define gv_fetchmethod_pvn_flags(a,b,c,d) Perl_gv_fetchmethod_pvn_flags(aTHX_ a,b,c,d)
+#define gv_fetchmethod_sv_flags(a,b,c) Perl_gv_fetchmethod_sv_flags(aTHX_ a,b,c)
#define gv_fetchpv(a,b,c) Perl_gv_fetchpv(aTHX_ a,b,c)
#define gv_fetchpvn_flags(a,b,c,d) Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d)
#define gv_fetchsv(a,b,c) Perl_gv_fetchsv(aTHX_ a,b,c)
XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
void
+gv_fetchmethod_flags_type(stash, methname, type, flags)
+ HV* stash
+ SV* methname
+ int type
+ I32 flags
+ PREINIT:
+ GV* gv;
+ PPCODE:
+ switch (type) {
+ case 0:
+ gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
+ break;
+ case 1:
+ gv = gv_fetchmethod_sv_flags(stash, methname, flags);
+ break;
+ case 2:
+ gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
+ break;
+ case 3: {
+ STRLEN len;
+ const char * const name = SvPV_const(methname, len);
+ gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
+ break;
+ }
+ }
+
+ XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+
+void
eval_sv(sv, flags)
SV* sv
I32 flags
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9; #23;
+
+use_ok('XS::APItest');
+
+sub method { 1 }
+
+ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "nothing", 1, 0);
+
+for my $type ( 1..3 ) {
+ is XS::APItest::gv_fetchmethod_flags_type(\%::, "method", $type, 0), "*main::method", "Sanity check";
+}
+
+ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 1, 0), "gv_fetchmethod_flags_sv() is nul-clean";
+ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 3, 0), "gv_fetchmethod_flags_pvn() is nul-clean";
+
+ok XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 0, 0), "gv_fetchmethod_flags() is not nul-clean";
+is XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 2, 0), "*main::method", "gv_fetchmethod_flags_pv() is not nul-clean";
+
+=begin
+{
+ use utf8;
+ use open qw( :utf8 :std );
+
+ package main;
+
+ sub method { 1 }
+ sub method { 1 }
+
+ for my $type ( 1..3 ) {
+ ::is XS::APItest::gv_fetchmethod_flags_type(\%main::, "method", $type, 0), "*main::method";
+ ::is XS::APItest::gv_fetchmethod_flags_type(\%main::, "method", $type, 0), "*main::method";
+
+ {
+ no strict 'refs';
+ ::ok !XS::APItest::gv_fetchmethod_flags_type(
+ \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+ "method", $type, 0);
+ ::ok !XS::APItest::gv_fetchmethod_flags_type(
+ \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+ "method", $type, 0);
+ }
+ ::ok !XS::APItest::gv_fetchmethod_flags_type(\%main::,
+ "\357\275\215\357\275\205\357\275\224\357\275\210\357\275\217\357\275\204",
+ $type, 0);
+ }
+}
+=cut
return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
}
+GV *
+Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
+}
+
+GV *
+Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
+ return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
+}
+
/* Don't merge this yet, as it's likely to get a len parameter, and possibly
even a U32 hash */
GV *
-Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
+Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
{
dVAR;
register const char *nend;
const U32 autoload = flags & GV_AUTOLOAD;
const U32 do_croak = flags & GV_CROAK;
- PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
if (SvTYPE(stash) < SVt_PVHV)
stash = NULL;
the error reporting code. */
}
- for (nend = name; *nend; nend++) {
+ for (nend = name; *nend || nend != (origname + len); nend++) {
if (*nend == '\'') {
nsplit = nend;
name = nend + 1;
#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_fetchmeth_autoload(stash,name,len,level) gv_fetchmeth_pvn_autoload(stash, name, len, level, 0)
+#define gv_fetchmethod_flags(stash,name,flags) gv_fetchmethod_pv_flags(stash, name, flags)
#define gv_AVadd(gv) gv_add_by_type((gv), SVt_PVAV)
#define gv_HVadd(gv) gv_add_by_type((gv), SVt_PVHV)
#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD \
assert(stash); assert(name)
-PERL_CALLCONV GV* Perl_gv_fetchmethod_flags(pTHX_ HV* stash, const char* name, U32 flags)
+PERL_CALLCONV GV* Perl_gv_fetchmethod_pv_flags(pTHX_ HV* stash, const char* name, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS \
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS \
assert(stash); assert(name)
+PERL_CALLCONV GV* Perl_gv_fetchmethod_pvn_flags(pTHX_ HV* stash, const char* name, STRLEN len, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS \
+ assert(stash); assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchmethod_sv_flags(pTHX_ HV* stash, SV* namesv, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS \
+ assert(stash); assert(namesv)
+
PERL_CALLCONV GV* Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_GV_FETCHPV \