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_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
ext/XS-APItest/t/keyword_plugin.t test keyword plugin mechanism
pMox |GP * |newGP |NN GV *const gv
pX |void |cvgv_set |NN CV* cv|NULLOK GV* gv
pX |void |cvstash_set |NN CV* cv|NULLOK HV* stash
-Ap |void |gv_init |NN GV* gv|NULLOK HV* stash|NN const char* name|STRLEN len|int multi
+Ap |void |gv_init_sv |NN GV* gv|NULLOK HV* stash|NN SV* namesv|int multi|U32 flags
+Ap |void |gv_init_pv |NN GV* gv|NULLOK HV* stash|NN const char* name \
+ |int multi|U32 flags
+Ap |void |gv_init_pvn |NN GV* gv|NULLOK HV* stash|NN const char* name \
+ |STRLEN len|int multi|U32 flags
Ap |void |gv_name_set |NN GV* gv|NN const char *name|U32 len|U32 flags
XMpd |void |gv_try_downgrade|NN GV* gv
Apd |HV* |gv_stashpv |NN const char* name|I32 flags
#endif
#if defined(PERL_IN_GV_C)
-s |void |gv_init_sv |NN GV *gv|const svtype sv_type
+s |void |gv_init_svtype |NN GV *gv|const svtype sv_type
s |void |gv_magicalize_isa |NN GV *gv
s |void |gv_magicalize_overload |NN GV *gv
s |HV* |gv_get_super_pkg|NN const char* name|I32 namelen
#define gv_fullname(a,b) Perl_gv_fullname(aTHX_ a,b)
#define gv_fullname4(a,b,c,d) Perl_gv_fullname4(aTHX_ a,b,c,d)
#define gv_handler(a,b) Perl_gv_handler(aTHX_ a,b)
-#define gv_init(a,b,c,d,e) Perl_gv_init(aTHX_ a,b,c,d,e)
+#define gv_init_pv(a,b,c,d,e) Perl_gv_init_pv(aTHX_ a,b,c,d,e)
+#define gv_init_pvn(a,b,c,d,e,f) Perl_gv_init_pvn(aTHX_ a,b,c,d,e,f)
+#define gv_init_sv(a,b,c,d,e) Perl_gv_init_sv(aTHX_ a,b,c,d,e)
#define gv_name_set(a,b,c,d) Perl_gv_name_set(aTHX_ a,b,c,d)
#define gv_stashpv(a,b) Perl_gv_stashpv(aTHX_ a,b)
#define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c)
# endif
# if defined(PERL_IN_GV_C)
#define gv_get_super_pkg(a,b) S_gv_get_super_pkg(aTHX_ a,b)
-#define gv_init_sv(a,b) S_gv_init_sv(aTHX_ a,b)
+#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 gv_magicalize_overload(a) S_gv_magicalize_overload(aTHX_ a)
#define require_tie_mod(a,b,c,d,e) S_require_tie_mod(aTHX_ a,b,c,d,e)
PUSHs(sv_2mortal(newSViv(i)));
void
+gv_init_type(namesv, multi, flags, type)
+ SV* namesv
+ int multi
+ I32 flags
+ int type
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(namesv, len);
+ GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
+ PPCODE:
+ if (SvTYPE(gv) == SVt_PVGV)
+ Perl_croak(aTHX_ "GV is already a PVGV");
+ switch (type) {
+ case 0:
+ gv_init(gv, PL_defstash, name, len, multi);
+ break;
+ case 1:
+ gv_init_sv(gv, PL_defstash, namesv, multi, flags);
+ break;
+ case 2:
+ gv_init_pv(gv, PL_defstash, name, multi, flags | SvUTF8(namesv));
+ break;
+ case 3:
+ gv_init_pvn(gv, PL_defstash, name, len, multi, flags | SvUTF8(namesv));
+ 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 => 10;
+
+use XS::APItest;
+
+is my $glob = XS::APItest::gv_init_type("sanity_check", 0, 0, 0), "*main::sanity_check";
+ok $::{sanity_check};
+
+for my $type (0..3) {
+ is my $glob = XS::APItest::gv_init_type("test$type", 0, 0, $type), "*main::test$type";
+ ok $::{"test$type"};
+}
}
void
-Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
+Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, int multi, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_INIT_SV;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ gv_init_pvn(gv, stash, namepv, namelen, multi, flags);
+}
+
+void
+Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, int multi, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_INIT_PV;
+ gv_init_pvn(gv, stash, name, strlen(name), multi, flags);
+}
+
+void
+Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi, U32 flags)
{
dVAR;
const U32 old_type = SvTYPE(gv);
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
- PERL_ARGS_ASSERT_GV_INIT;
+ PERL_ARGS_ASSERT_GV_INIT_PVN;
assert (!(proto && has_constant));
if (has_constant) {
}
STATIC void
-S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
+S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
{
- PERL_ARGS_ASSERT_GV_INIT_SV;
+ PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
switch (sv_type) {
case SVt_PVIO:
if (SvTYPE(gv) == SVt_PVGV) {
if (add) {
GvMULTI_on(gv);
- gv_init_sv(gv, sv_type);
+ gv_init_svtype(gv, sv_type);
if (len == 1 && stash == PL_defstash
&& (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
if (*name == '!')
(void)hv_store(stash,name,len,(SV *)gv,0);
else SvREFCNT_dec(gv), gv = NULL;
}
- if (gv) gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
+ if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
return gv;
}
#define gv_efullname3(sv,gv,prefix) gv_efullname4(sv,gv,prefix,TRUE)
#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_AVadd(gv) gv_add_by_type((gv), SVt_PVAV)
#define gv_HVadd(gv) gv_add_by_type((gv), SVt_PVHV)
PERL_CALLCONV CV* Perl_gv_handler(pTHX_ HV* stash, I32 id)
__attribute__warn_unused_result__;
-PERL_CALLCONV void Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi)
+PERL_CALLCONV void Perl_gv_init_pv(pTHX_ GV* gv, HV* stash, const char* name, int multi, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_3);
-#define PERL_ARGS_ASSERT_GV_INIT \
+#define PERL_ARGS_ASSERT_GV_INIT_PV \
assert(gv); assert(name)
+PERL_CALLCONV void Perl_gv_init_pvn(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GV_INIT_PVN \
+ assert(gv); assert(name)
+
+PERL_CALLCONV void Perl_gv_init_sv(pTHX_ GV* gv, HV* stash, SV* namesv, int multi, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GV_INIT_SV \
+ assert(gv); assert(namesv)
+
PERL_CALLCONV void Perl_gv_name_set(pTHX_ GV* gv, const char *name, U32 len, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_GV_GET_SUPER_PKG \
assert(name)
-STATIC void S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
+STATIC void S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_GV_INIT_SV \
+#define PERL_ARGS_ASSERT_GV_INIT_SVTYPE \
assert(gv)
STATIC void S_gv_magicalize_isa(pTHX_ GV *gv)