ext/XS-APItest/t/blockhooks-csc.t XS::APItest: more tests for PL_blockhooks
ext/XS-APItest/t/blockhooks.t XS::APItest: tests for PL_blockhooks
ext/XS-APItest/t/Block.pm Helper for ./blockhooks.t
+ext/XS-APItest/t/call_checker.t test call checker plugin API
ext/XS-APItest/t/caller.t XS::APItest: tests for caller_cx
ext/XS-APItest/t/call.t XS::APItest extension
ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API
ext/XS-APItest/t/keyword_multiline.t test keyword plugin parsing across lines
ext/XS-APItest/t/keyword_plugin.t test keyword plugin mechanism
ext/XS-APItest/t/looprest.t test recursive descent statement-sequence parsing
+ext/XS-APItest/t/magic_chain.t test low-level MAGIC chain handling
ext/XS-APItest/t/Markers.pm Helper for ./blockhooks.t
ext/XS-APItest/t/my_cxt.t XS::APItest: test MY_CXT interface
ext/XS-APItest/t/my_exit.t XS::APItest: test my_exit
ext/XS-APItest/t/Null.pm Helper for ./blockhooks.t
+ext/XS-APItest/t/op_contextualize.t test op_contextualize() API
ext/XS-APItest/t/op.t XS::APItest: tests for OP related APIs
ext/XS-APItest/t/peep.t test PL_peepp/PL_rpeepp
ext/XS-APItest/t/pmflag.t Test removal of Perl_pmflag()
ext/XS-APItest/t/ptr_table.t Test ptr_table_* APIs
ext/XS-APItest/t/push.t XS::APItest extension
ext/XS-APItest/t/rmagical.t XS::APItest extension
+ext/XS-APItest/t/rv2cv_op_cv.t test rv2cv_op_cv() API
ext/XS-APItest/t/savehints.t test SAVEHINTS() API
ext/XS-APItest/t/stuff_svcur_bug.t test for a bug in lex_stuff_pvn
ext/XS-APItest/t/svpeek.t XS::APItest extension
=cut
*/
+typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);
+
/*
* Local variables:
* c-indentation-style: bsd
{ PERL_MAGIC_tied, "tied(P)" },
{ PERL_MAGIC_sig, "sig(S)" },
{ PERL_MAGIC_uvar, "uvar(U)" },
+ { PERL_MAGIC_checkcall, "checkcall(])" },
{ PERL_MAGIC_overload_elem, "overload_elem(a)" },
{ PERL_MAGIC_overload_table, "overload_table(c)" },
{ PERL_MAGIC_regdatum, "regdatum(d)" },
pd |void |mg_localize |NN SV* sv|NN SV* nsv|bool setmagic
ApdR |MAGIC* |mg_find |NULLOK const SV* sv|int type
Apd |int |mg_free |NN SV* sv
+Apd |void |mg_free_type |NN SV* sv|int how
Apd |int |mg_get |NN SV* sv
Apd |U32 |mg_length |NN SV* sv
Apd |void |mg_magical |NN SV* sv
Apda |OP* |newWHILEOP |I32 flags|I32 debuggable|NULLOK LOOP* loop \
|I32 whileline|NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \
|I32 has_my
+Apd |CV* |rv2cv_op_cv |NN OP *cvop|U32 flags
+Apd |OP* |ck_entersub_args_list|NN OP *entersubop
+Apd |OP* |ck_entersub_args_proto|NN OP *entersubop|NN GV *namegv|NN SV *protosv
+Apd |OP* |ck_entersub_args_proto_or_list|NN OP *entersubop|NN GV *namegv|NN SV *protosv
+Apd |void |cv_get_call_checker|NN CV *cv|NN Perl_call_checker *ckfun_p|NN SV **ckobj_p
+Apd |void |cv_set_call_checker|NN CV *cv|NN Perl_call_checker ckfun|NN SV *ckobj
Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
Ap |char* |scan_vstring |NN const char *s|NN const char *const e \
|NN SV *sv
#endif
: Used in perly.y
p |OP* |sawparens |NULLOK OP* o
+Apd |OP* |op_contextualize|NN OP* o|I32 context
: Used in perly.y
p |OP* |scalar |NULLOK OP* o
#if defined(PERL_IN_OP_C)
#define cast_iv(a) Perl_cast_iv(aTHX_ a)
#define cast_ulong(a) Perl_cast_ulong(aTHX_ a)
#define cast_uv(a) Perl_cast_uv(aTHX_ a)
+#define ck_entersub_args_list(a) Perl_ck_entersub_args_list(aTHX_ a)
+#define ck_entersub_args_proto(a,b,c) Perl_ck_entersub_args_proto(aTHX_ a,b,c)
+#define ck_entersub_args_proto_or_list(a,b,c) Perl_ck_entersub_args_proto_or_list(aTHX_ a,b,c)
#ifndef PERL_IMPLICIT_CONTEXT
#define ck_warner Perl_ck_warner
#define ck_warner_d Perl_ck_warner_d
#define custom_op_desc(a) Perl_custom_op_desc(aTHX_ a)
#define custom_op_name(a) Perl_custom_op_name(aTHX_ a)
#define cv_const_sv(a) Perl_cv_const_sv(aTHX_ a)
+#define cv_get_call_checker(a,b,c) Perl_cv_get_call_checker(aTHX_ a,b,c)
+#define cv_set_call_checker(a,b,c) Perl_cv_set_call_checker(aTHX_ a,b,c)
#define cv_undef(a) Perl_cv_undef(aTHX_ a)
#define cx_dump(a) Perl_cx_dump(aTHX_ a)
#define cxinc() Perl_cxinc(aTHX)
#define mg_copy(a,b,c,d) Perl_mg_copy(aTHX_ a,b,c,d)
#define mg_find(a,b) Perl_mg_find(aTHX_ a,b)
#define mg_free(a) Perl_mg_free(aTHX_ a)
+#define mg_free_type(a,b) Perl_mg_free_type(aTHX_ a,b)
#define mg_get(a) Perl_mg_get(aTHX_ a)
#define mg_length(a) Perl_mg_length(aTHX_ a)
#define mg_magical(a) Perl_mg_magical(aTHX_ a)
#define new_version(a) Perl_new_version(aTHX_ a)
#define ninstr Perl_ninstr
#define nothreadhook() Perl_nothreadhook(aTHX)
+#define op_contextualize(a,b) Perl_op_contextualize(aTHX_ a,b)
#define op_dump(a) Perl_op_dump(aTHX_ a)
#define op_free(a) Perl_op_free(aTHX_ a)
#define op_null(a) Perl_op_null(aTHX_ a)
#define rsignal_state(a) Perl_rsignal_state(aTHX_ a)
#define runops_debug() Perl_runops_debug(aTHX)
#define runops_standard() Perl_runops_standard(aTHX)
+#define rv2cv_op_cv(a,b) Perl_rv2cv_op_cv(aTHX_ a,b)
#define safesyscalloc Perl_safesyscalloc
#define safesysfree Perl_safesysfree
#define safesysmalloc Perl_safesysmalloc
}
}
+STATIC OP *
+THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+ return ck_entersub_args_list(entersubop);
+}
+
+STATIC OP *
+THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+ OP *aop = cUNOPx(entersubop)->op_first;
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+ for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
+ op_contextualize(aop, G_SCALAR);
+ }
+ return entersubop;
+}
+
+STATIC OP *
+THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+ OP *sumop = NULL;
+ OP *pushop = cUNOPx(entersubop)->op_first;
+ if (!pushop->op_sibling)
+ pushop = cUNOPx(pushop)->op_first;
+ while (1) {
+ OP *aop = pushop->op_sibling;
+ if (!aop->op_sibling)
+ break;
+ pushop->op_sibling = aop->op_sibling;
+ aop->op_sibling = NULL;
+ op_contextualize(aop, G_SCALAR);
+ if (sumop) {
+ sumop = newBINOP(OP_ADD, 0, sumop, aop);
+ } else {
+ sumop = aop;
+ }
+ }
+ if (!sumop)
+ sumop = newSVOP(OP_CONST, 0, newSViv(0));
+ op_free(entersubop);
+ return sumop;
+}
+
/** RPN keyword parser **/
#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
av_clear(MY_CXT.bhkav);
void
+test_magic_chain()
+ PREINIT:
+ SV *sv;
+ MAGIC *callmg, *uvarmg;
+ CODE:
+ sv = sv_2mortal(newSV(0));
+ if (SvTYPE(sv) >= SVt_PVMG) croak("fail");
+ if (SvMAGICAL(sv)) croak("fail");
+ sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
+ if (SvTYPE(sv) < SVt_PVMG) croak("fail");
+ if (!SvMAGICAL(sv)) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_uvar)) croak("fail");
+ callmg = mg_find(sv, PERL_MAGIC_checkcall);
+ if (!callmg) croak("fail");
+ if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
+ croak("fail");
+ sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
+ if (SvTYPE(sv) < SVt_PVMG) croak("fail");
+ if (!SvMAGICAL(sv)) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak("fail");
+ uvarmg = mg_find(sv, PERL_MAGIC_uvar);
+ if (!uvarmg) croak("fail");
+ if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
+ croak("fail");
+ if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
+ croak("fail");
+ mg_free_type(sv, PERL_MAGIC_vec);
+ if (SvTYPE(sv) < SVt_PVMG) croak("fail");
+ if (!SvMAGICAL(sv)) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak("fail");
+ if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
+ croak("fail");
+ if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
+ croak("fail");
+ mg_free_type(sv, PERL_MAGIC_uvar);
+ if (SvTYPE(sv) < SVt_PVMG) croak("fail");
+ if (!SvMAGICAL(sv)) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_uvar)) croak("fail");
+ if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
+ croak("fail");
+ sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
+ if (SvTYPE(sv) < SVt_PVMG) croak("fail");
+ if (!SvMAGICAL(sv)) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak("fail");
+ uvarmg = mg_find(sv, PERL_MAGIC_uvar);
+ if (!uvarmg) croak("fail");
+ if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
+ croak("fail");
+ if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
+ croak("fail");
+ mg_free_type(sv, PERL_MAGIC_checkcall);
+ if (SvTYPE(sv) < SVt_PVMG) croak("fail");
+ if (!SvMAGICAL(sv)) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_checkcall)) croak("fail");
+ if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
+ croak("fail");
+ mg_free_type(sv, PERL_MAGIC_uvar);
+ if (SvMAGICAL(sv)) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_checkcall)) croak("fail");
+ if (mg_find(sv, PERL_MAGIC_uvar)) croak("fail");
+
+void
+test_op_contextualize()
+ PREINIT:
+ OP *o;
+ CODE:
+ o = newSVOP(OP_CONST, 0, newSViv(0));
+ o->op_flags &= ~OPf_WANT;
+ o = op_contextualize(o, G_SCALAR);
+ if (o->op_type != OP_CONST ||
+ (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
+ croak("fail");
+ op_free(o);
+ o = newSVOP(OP_CONST, 0, newSViv(0));
+ o->op_flags &= ~OPf_WANT;
+ o = op_contextualize(o, G_ARRAY);
+ if (o->op_type != OP_CONST ||
+ (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
+ croak("fail");
+ op_free(o);
+ o = newSVOP(OP_CONST, 0, newSViv(0));
+ o->op_flags &= ~OPf_WANT;
+ o = op_contextualize(o, G_VOID);
+ if (o->op_type != OP_NULL) croak("fail");
+ op_free(o);
+
+void
+test_rv2cv_op_cv()
+ PROTOTYPE:
+ PREINIT:
+ GV *troc_gv, *wibble_gv;
+ CV *troc_cv;
+ OP *o;
+ CODE:
+ troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
+ troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
+ wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV);
+ o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
+ if (rv2cv_op_cv(o, 0) != troc_cv) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
+ croak("fail");
+ o->op_private |= OPpENTERSUB_AMPER;
+ if (rv2cv_op_cv(o, 0)) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak("fail");
+ o->op_private &= ~OPpENTERSUB_AMPER;
+ if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak("fail");
+ if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak("fail");
+ op_free(o);
+ o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
+ o->op_private = OPpCONST_BARE;
+ o = newCVREF(0, o);
+ if (rv2cv_op_cv(o, 0) != troc_cv) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
+ croak("fail");
+ o->op_private |= OPpENTERSUB_AMPER;
+ if (rv2cv_op_cv(o, 0)) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak("fail");
+ op_free(o);
+ o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
+ if (rv2cv_op_cv(o, 0) != troc_cv) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
+ croak("fail");
+ o->op_private |= OPpENTERSUB_AMPER;
+ if (rv2cv_op_cv(o, 0)) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak("fail");
+ o->op_private &= ~OPpENTERSUB_AMPER;
+ if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak("fail");
+ if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak("fail");
+ op_free(o);
+ o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
+ if (rv2cv_op_cv(o, 0)) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak("fail");
+ o->op_private |= OPpENTERSUB_AMPER;
+ if (rv2cv_op_cv(o, 0)) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak("fail");
+ o->op_private &= ~OPpENTERSUB_AMPER;
+ if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak("fail");
+ if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak("fail");
+ op_free(o);
+ o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
+ if (rv2cv_op_cv(o, 0)) croak("fail");
+ if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak("fail");
+ op_free(o);
+
+void
+test_cv_getset_call_checker()
+ PREINIT:
+ CV *troc_cv, *tsh_cv;
+ Perl_call_checker ckfun;
+ SV *ckobj;
+ CODE:
+#define check_cc(cv, xckfun, xckobj) \
+ do { \
+ cv_get_call_checker((cv), &ckfun, &ckobj); \
+ if (ckfun != (xckfun) || ckobj != (xckobj)) croak("fail"); \
+ } while(0)
+ troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
+ tsh_cv = get_cv("XS::APItest::test_savehints", 0);
+ check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
+ check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
+ cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
+ &PL_sv_yes);
+ check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
+ check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
+ cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
+ check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
+ check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
+ cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
+ (SV*)tsh_cv);
+ check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
+ check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
+ cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
+ (SV*)troc_cv);
+ check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
+ check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
+ if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak("fail");
+ if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak("fail");
+#undef check_cc
+
+void
+cv_set_call_checker_lists(CV *cv)
+ CODE:
+ cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
+
+void
+cv_set_call_checker_scalars(CV *cv)
+ CODE:
+ cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
+
+void
+cv_set_call_checker_proto(CV *cv, SV *proto)
+ CODE:
+ if (SvROK(proto))
+ proto = SvRV(proto);
+ cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
+
+void
+cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
+ CODE:
+ if (SvROK(proto))
+ proto = SvRV(proto);
+ cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
+
+void
+cv_set_call_checker_multi_sum(CV *cv)
+ CODE:
+ cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
+
+void
test_savehints()
PREINIT:
SV **svp, *sv;
--- /dev/null
+use warnings;
+use strict;
+use Test::More tests => 64;
+
+use XS::APItest;
+
+XS::APItest::test_cv_getset_call_checker();
+ok 1;
+
+my @z = ();
+my @a = qw(a);
+my @b = qw(a b);
+my @c = qw(a b c);
+
+my($foo_got, $foo_ret);
+sub foo($@) { $foo_got = [ @_ ]; return "z"; }
+
+sub bar (\@$) { }
+sub baz { }
+
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ 2, qw(a b c) ];
+is $foo_ret, "z";
+
+$foo_got = undef;
+eval q{$foo_ret = &foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ qw(a b), qw(a b c) ];
+is $foo_ret, "z";
+
+cv_set_call_checker_lists(\&foo);
+
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ qw(a b), qw(a b c) ];
+is $foo_ret, "z";
+
+$foo_got = undef;
+eval q{$foo_ret = &foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ qw(a b), qw(a b c) ];
+is $foo_ret, "z";
+
+cv_set_call_checker_scalars(\&foo);
+
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ 2, 3 ];
+is $foo_ret, "z";
+
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c, @a, @c);};
+is $@, "";
+is_deeply $foo_got, [ 2, 3, 1, 3 ];
+is $foo_ret, "z";
+
+$foo_got = undef;
+eval q{$foo_ret = foo(@b);};
+is $@, "";
+is_deeply $foo_got, [ 2 ];
+is $foo_ret, "z";
+
+$foo_got = undef;
+eval q{$foo_ret = foo();};
+is $@, "";
+is_deeply $foo_got, [];
+is $foo_ret, "z";
+
+$foo_got = undef;
+eval q{$foo_ret = &foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ qw(a b), qw(a b c) ];
+is $foo_ret, "z";
+
+cv_set_call_checker_proto(\&foo, "\\\@\$");
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ \@b, 3 ];
+is $foo_ret, "z";
+
+cv_set_call_checker_proto(\&foo, undef);
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+isnt $@, "";
+is_deeply $foo_got, undef;
+is $foo_ret, "z";
+
+cv_set_call_checker_proto(\&foo, \&bar);
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ \@b, 3 ];
+is $foo_ret, "z";
+
+cv_set_call_checker_proto(\&foo, \&baz);
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+isnt $@, "";
+is_deeply $foo_got, undef;
+is $foo_ret, "z";
+
+cv_set_call_checker_proto_or_list(\&foo, "\\\@\$");
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ \@b, 3 ];
+is $foo_ret, "z";
+
+cv_set_call_checker_proto_or_list(\&foo, undef);
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ qw(a b), qw(a b c) ];
+is $foo_ret, "z";
+
+cv_set_call_checker_proto_or_list(\&foo, \&bar);
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ \@b, 3 ];
+is $foo_ret, "z";
+
+cv_set_call_checker_proto_or_list(\&foo, \&baz);
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ qw(a b), qw(a b c) ];
+is $foo_ret, "z";
+
+cv_set_call_checker_multi_sum(\&foo);
+
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c);};
+is $@, "";
+is_deeply $foo_got, undef;
+is $foo_ret, 5;
+
+$foo_got = undef;
+eval q{$foo_ret = foo(@b);};
+is $@, "";
+is_deeply $foo_got, undef;
+is $foo_ret, 2;
+
+$foo_got = undef;
+eval q{$foo_ret = foo();};
+is $@, "";
+is_deeply $foo_got, undef;
+is $foo_ret, 0;
+
+$foo_got = undef;
+eval q{$foo_ret = foo(@b, @c, @a, @c);};
+is $@, "";
+is_deeply $foo_got, undef;
+is $foo_ret, 9;
+
+1;
--- /dev/null
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+XS::APItest::test_magic_chain();
+ok 1;
+
+1;
--- /dev/null
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+XS::APItest::test_op_contextualize();
+ok 1;
+
+1;
--- /dev/null
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+XS::APItest::test_rv2cv_op_cv();
+ok 1;
+
+1;
Perl_cast_iv
Perl_cast_ulong
Perl_cast_uv
+Perl_ck_entersub_args_list
+Perl_ck_entersub_args_proto
+Perl_ck_entersub_args_proto_or_list
Perl_ck_warner
Perl_ck_warner_d
Perl_ckwarn
Perl_custom_op_desc
Perl_custom_op_name
Perl_cv_const_sv
+Perl_cv_get_call_checker
+Perl_cv_set_call_checker
Perl_cv_undef
Perl_cvgv_set
Perl_cx_dump
Perl_mg_copy
Perl_mg_find
Perl_mg_free
+Perl_mg_free_type
Perl_mg_get
Perl_mg_length
Perl_mg_magical
Perl_ninstr
Perl_nothreadhook
Perl_op_clear
+Perl_op_contextualize
Perl_op_dump
Perl_op_free
Perl_op_null
Perl_rsignal_state
Perl_runops_debug
Perl_runops_standard
+Perl_rv2cv_op_cv
Perl_safesyscalloc
Perl_safesysfree
Perl_safesysmalloc
case PERL_MAGIC_rhash:
case PERL_MAGIC_symtab:
case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */
+ case PERL_MAGIC_checkcall:
return 0;
default:
return 1;
}
}
+#define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
+static void
+S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
+{
+ const MGVTBL* const vtbl = mg->mg_virtual;
+ if (vtbl && vtbl->svt_free)
+ vtbl->svt_free(aTHX_ sv, mg);
+ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
+ if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
+ Safefree(mg->mg_ptr);
+ else if (mg->mg_len == HEf_SVKEY)
+ SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
+ }
+ if (mg->mg_flags & MGf_REFCOUNTED)
+ SvREFCNT_dec(mg->mg_obj);
+ Safefree(mg);
+}
+
/*
=for apidoc mg_free
PERL_ARGS_ASSERT_MG_FREE;
for (mg = SvMAGIC(sv); mg; mg = moremagic) {
- const MGVTBL* const vtbl = mg->mg_virtual;
moremagic = mg->mg_moremagic;
- if (vtbl && vtbl->svt_free)
- vtbl->svt_free(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
- if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
- Safefree(mg->mg_ptr);
- else if (mg->mg_len == HEf_SVKEY)
- SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
- }
- if (mg->mg_flags & MGf_REFCOUNTED)
- SvREFCNT_dec(mg->mg_obj);
- Safefree(mg);
+ mg_free_struct(sv, mg);
SvMAGIC_set(sv, moremagic);
}
SvMAGIC_set(sv, NULL);
return 0;
}
+/*
+=for apidoc Am|void|mg_free_type|SV *sv|int how
+
+Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
+
+=cut
+*/
+
+void
+Perl_mg_free_type(pTHX_ SV *sv, int how)
+{
+ MAGIC *mg, *prevmg, *moremg;
+ PERL_ARGS_ASSERT_MG_FREE_TYPE;
+ for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
+ MAGIC *newhead;
+ moremg = mg->mg_moremagic;
+ if (mg->mg_type == how) {
+ /* temporarily move to the head of the magic chain, in case
+ custom free code relies on this historical aspect of mg_free */
+ if (prevmg) {
+ prevmg->mg_moremagic = moremg;
+ mg->mg_moremagic = SvMAGIC(sv);
+ SvMAGIC_set(sv, mg);
+ }
+ newhead = mg->mg_moremagic;
+ mg_free_struct(sv, mg);
+ SvMAGIC_set(sv, newhead);
+ mg = prevmg;
+ }
+ }
+ mg_magical(sv);
+}
+
#include <signal.h>
U32
/* Contextualizers */
+/*
+=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
+
+Applies a syntactic context to an op tree representing an expression.
+I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
+or C<G_VOID> to specify the context to apply. The modified op tree
+is returned.
+
+=cut
+*/
+
+OP *
+Perl_op_contextualize(pTHX_ OP *o, I32 context)
+{
+ PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
+ switch (context) {
+ case G_SCALAR: return scalar(o);
+ case G_ARRAY: return list(o);
+ case G_VOID: return scalarvoid(o);
+ default:
+ Perl_croak(aTHX_ "panic: op_contextualize bad context");
+ return o;
+ }
+}
+
#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
static OP *
return ck_fun(o);
}
-OP *
-Perl_ck_subr(pTHX_ OP *o)
-{
- dVAR;
- OP *prev = ((cUNOPo->op_first->op_sibling)
- ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
- OP *o2 = prev->op_sibling;
- OP *cvop;
- const char *proto = NULL;
- const char *proto_end = NULL;
- CV *cv = NULL;
- GV *namegv = NULL;
- int optional = 0;
- I32 arg = 0;
- I32 contextclass = 0;
- const char *e = NULL;
-
- PERL_ARGS_ASSERT_CK_SUBR;
+/*
+=for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
+
+Examines an op, which is expected to identify a subroutine at runtime,
+and attempts to determine at compile time which subroutine it identifies.
+This is normally used during Perl compilation to determine whether
+a prototype can be applied to a function call. I<cvop> is the op
+being considered, normally an C<rv2cv> op. A pointer to the identified
+subroutine is returned, if it could be determined statically, and a null
+pointer is returned if it was not possible to determine statically.
+
+Currently, the subroutine can be identified statically if the RV that the
+C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
+A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
+suitable if the constant value must be an RV pointing to a CV. Details of
+this process may change in future versions of Perl. If the C<rv2cv> op
+has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
+the subroutine statically: this flag is used to suppress compile-time
+magic on a subroutine call, forcing it to use default runtime behaviour.
+
+If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
+of a GV reference is modified. If a GV was examined and its CV slot was
+found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
+If the op is not optimised away, and the CV slot is later populated with
+a subroutine having a prototype, that flag eventually triggers the warning
+"called too early to check prototype".
+
+If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
+of returning a pointer to the subroutine it returns a pointer to the
+GV giving the most appropriate name for the subroutine in this context.
+Normally this is just the C<CvGV> of the subroutine, but for an anonymous
+(C<CvANON>) subroutine that is referenced through a GV it will be the
+referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
+A null pointer is returned as usual if there is no statically-determinable
+subroutine.
- o->op_private |= OPpENTERSUB_HASTARG;
- o->op_private |= (PL_hints & HINT_STRICT_REFS);
- if (PERLDB_SUB && PL_curstash != PL_debstash)
- o->op_private |= OPpENTERSUB_DB;
+=cut
+*/
- for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
- if (cvop->op_type == OP_RV2CV) {
- o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
- op_null(cvop); /* disable rv2cv */
- if (!(o->op_private & OPpENTERSUB_AMPER)) {
- SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
- GV *gv = NULL;
- switch (tmpop->op_type) {
- case OP_GV: {
- gv = cGVOPx_gv(tmpop);
- cv = GvCVu(gv);
- if (!cv)
- tmpop->op_private |= OPpEARLY_CV;
- } break;
- case OP_CONST: {
- SV *sv = cSVOPx_sv(tmpop);
- if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
- cv = (CV*)SvRV(sv);
- } break;
- }
- if (cv && SvPOK(cv)) {
- STRLEN len;
- namegv = gv && CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV(MUTABLE_SV(cv), len);
- proto_end = proto + len;
+CV *
+Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
+{
+ OP *rvop;
+ CV *cv;
+ GV *gv;
+ PERL_ARGS_ASSERT_RV2CV_OP_CV;
+ if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
+ Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
+ if (cvop->op_type != OP_RV2CV)
+ return NULL;
+ if (cvop->op_private & OPpENTERSUB_AMPER)
+ return NULL;
+ if (!(cvop->op_flags & OPf_KIDS))
+ return NULL;
+ rvop = cUNOPx(cvop)->op_first;
+ switch (rvop->op_type) {
+ case OP_GV: {
+ gv = cGVOPx_gv(rvop);
+ cv = GvCVu(gv);
+ if (!cv) {
+ if (flags & RV2CVOPCV_MARK_EARLY)
+ rvop->op_private |= OPpEARLY_CV;
+ return NULL;
}
- }
+ } break;
+ case OP_CONST: {
+ SV *rv = cSVOPx_sv(rvop);
+ if (!SvROK(rv))
+ return NULL;
+ cv = (CV*)SvRV(rv);
+ gv = NULL;
+ } break;
+ default: {
+ return NULL;
+ } break;
}
- else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
- if (o2->op_type == OP_CONST)
- o2->op_private &= ~OPpCONST_STRICT;
- else if (o2->op_type == OP_LIST) {
- OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
- if (sib && sib->op_type == OP_CONST)
- sib->op_private &= ~OPpCONST_STRICT;
- }
+ if (SvTYPE((SV*)cv) != SVt_PVCV)
+ return NULL;
+ if (flags & RV2CVOPCV_RETURN_NAME_GV) {
+ if (!CvANON(cv) || !gv)
+ gv = CvGV(cv);
+ return (CV*)gv;
+ } else {
+ return cv;
}
+}
- if (!proto) {
- while (o2 != cvop) {
- if (PL_madskills && o2->op_type == OP_STUB) {
- o2 = o2->op_sibling;
- continue;
- }
+/*
+=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
- /* Yes, this while loop is duplicated. But it's a lot clearer
- to see what is going on without that massive switch(*proto)
- block just here. */
+Performs the default fixup of the arguments part of an C<entersub>
+op tree. This consists of applying list context to each of the
+argument ops. This is the standard treatment used on a call marked
+with C<&>, or a method call, or a call through a subroutine reference,
+or any other call where the callee can't be identified at compile time,
+or a call where the callee has no prototype.
- list(o2); /* This is only called if !proto */
+=cut
+*/
- mod(o2, OP_ENTERSUB);
- o2 = o2->op_sibling;
- } /* while */
- } else {
- while (o2 != cvop) {
- OP* o3;
- if (PL_madskills && o2->op_type == OP_STUB) {
- o2 = o2->op_sibling;
- continue;
- }
- if (PL_madskills && o2->op_type == OP_NULL)
- o3 = ((UNOP*)o2)->op_first;
- else
- o3 = o2;
+OP *
+Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
+{
+ OP *aop;
+ PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
+ aop = cUNOPx(entersubop)->op_first;
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+ for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
+ if (!(PL_madskills && aop->op_type == OP_STUB)) {
+ list(aop);
+ mod(aop, OP_ENTERSUB);
+ }
+ }
+ return entersubop;
+}
- if (proto >= proto_end)
- return too_many_arguments(o, gv_ename(namegv));
+/*
+=for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
+
+Performs the fixup of the arguments part of an C<entersub> op tree
+based on a subroutine prototype. This makes various modifications to
+the argument ops, from applying context up to inserting C<refgen> ops,
+and checking the number and syntactic types of arguments, as directed by
+the prototype. This is the standard treatment used on a subroutine call,
+not marked with C<&>, where the callee can be identified at compile time
+and has a prototype.
+
+I<protosv> supplies the subroutine prototype to be applied to the call.
+It may be a normal defined scalar, of which the string value will be used.
+Alternatively, for convenience, it may be a subroutine object (a C<CV*>
+that has been cast to C<SV*>) which has a prototype. The prototype
+supplied, in whichever form, does not need to match the actual callee
+referenced by the op tree.
+
+If the argument ops disagree with the prototype, for example by having
+an unacceptable number of arguments, a valid op tree is returned anyway.
+The error is reflected in the parser state, normally resulting in a single
+exception at the top level of parsing which covers all the compilation
+errors that occurred. In the error message, the callee is referred to
+by the name defined by the I<namegv> parameter.
- switch (*proto) {
- case ';':
- optional = 1;
- proto++;
- continue;
- case '_':
- /* _ must be at the end */
- if (proto[1] && proto[1] != ';')
- goto oops;
- case '$':
- proto++;
- arg++;
- scalar(o2);
- break;
- case '%':
- case '@':
- list(o2);
- arg++;
- break;
- case '&':
- proto++;
- arg++;
- if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
- bad_type(arg,
- arg == 1 ? "block or sub {}" : "sub {}",
- gv_ename(namegv), o3);
- break;
- case '*':
- /* '*' allows any scalar type, including bareword */
- proto++;
- arg++;
- if (o3->op_type == OP_RV2GV)
- goto wrapref; /* autoconvert GLOB -> GLOBref */
- else if (o3->op_type == OP_CONST)
- o3->op_private &= ~OPpCONST_STRICT;
- else if (o3->op_type == OP_ENTERSUB) {
- /* accidental subroutine, revert to bareword */
- OP *gvop = ((UNOP*)o3)->op_first;
- if (gvop && gvop->op_type == OP_NULL) {
- gvop = ((UNOP*)gvop)->op_first;
- if (gvop) {
- for (; gvop->op_sibling; gvop = gvop->op_sibling)
- ;
- if (gvop &&
- (gvop->op_private & OPpENTERSUB_NOPAREN) &&
- (gvop = ((UNOP*)gvop)->op_first) &&
- gvop->op_type == OP_GV)
- {
- GV * const gv = cGVOPx_gv(gvop);
- OP * const sibling = o2->op_sibling;
- SV * const n = newSVpvs("");
+=cut
+*/
+
+OP *
+Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
+{
+ STRLEN proto_len;
+ const char *proto, *proto_end;
+ OP *aop, *prev, *cvop;
+ int optional = 0;
+ I32 arg = 0;
+ I32 contextclass = 0;
+ const char *e = NULL;
+ PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
+ if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
+ Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
+ proto = SvPV(protosv, proto_len);
+ proto_end = proto + proto_len;
+ aop = cUNOPx(entersubop)->op_first;
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+ prev = aop;
+ aop = aop->op_sibling;
+ for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
+ while (aop != cvop) {
+ OP* o3;
+ if (PL_madskills && aop->op_type == OP_STUB) {
+ aop = aop->op_sibling;
+ continue;
+ }
+ if (PL_madskills && aop->op_type == OP_NULL)
+ o3 = ((UNOP*)aop)->op_first;
+ else
+ o3 = aop;
+
+ if (proto >= proto_end)
+ return too_many_arguments(entersubop, gv_ename(namegv));
+
+ switch (*proto) {
+ case ';':
+ optional = 1;
+ proto++;
+ continue;
+ case '_':
+ /* _ must be at the end */
+ if (proto[1] && proto[1] != ';')
+ goto oops;
+ case '$':
+ proto++;
+ arg++;
+ scalar(aop);
+ break;
+ case '%':
+ case '@':
+ list(aop);
+ arg++;
+ break;
+ case '&':
+ proto++;
+ arg++;
+ if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
+ bad_type(arg,
+ arg == 1 ? "block or sub {}" : "sub {}",
+ gv_ename(namegv), o3);
+ break;
+ case '*':
+ /* '*' allows any scalar type, including bareword */
+ proto++;
+ arg++;
+ if (o3->op_type == OP_RV2GV)
+ goto wrapref; /* autoconvert GLOB -> GLOBref */
+ else if (o3->op_type == OP_CONST)
+ o3->op_private &= ~OPpCONST_STRICT;
+ else if (o3->op_type == OP_ENTERSUB) {
+ /* accidental subroutine, revert to bareword */
+ OP *gvop = ((UNOP*)o3)->op_first;
+ if (gvop && gvop->op_type == OP_NULL) {
+ gvop = ((UNOP*)gvop)->op_first;
+ if (gvop) {
+ for (; gvop->op_sibling; gvop = gvop->op_sibling)
+ ;
+ if (gvop &&
+ (gvop->op_private & OPpENTERSUB_NOPAREN) &&
+ (gvop = ((UNOP*)gvop)->op_first) &&
+ gvop->op_type == OP_GV)
+ {
+ GV * const gv = cGVOPx_gv(gvop);
+ OP * const sibling = aop->op_sibling;
+ SV * const n = newSVpvs("");
#ifdef PERL_MAD
- OP * const oldo2 = o2;
+ OP * const oldaop = aop;
#else
- op_free(o2);
+ op_free(aop);
#endif
- gv_fullname4(n, gv, "", FALSE);
- o2 = newSVOP(OP_CONST, 0, n);
- op_getmad(oldo2,o2,'O');
- prev->op_sibling = o2;
- o2->op_sibling = sibling;
- }
+ gv_fullname4(n, gv, "", FALSE);
+ aop = newSVOP(OP_CONST, 0, n);
+ op_getmad(oldaop,aop,'O');
+ prev->op_sibling = aop;
+ aop->op_sibling = sibling;
}
}
}
- scalar(o2);
- break;
- case '[': case ']':
- goto oops;
+ }
+ scalar(aop);
+ break;
+ case '[': case ']':
+ goto oops;
+ break;
+ case '\\':
+ proto++;
+ arg++;
+ again:
+ switch (*proto++) {
+ case '[':
+ if (contextclass++ == 0) {
+ e = strchr(proto, ']');
+ if (!e || e == proto)
+ goto oops;
+ }
+ else
+ goto oops;
+ goto again;
break;
- case '\\':
- proto++;
- arg++;
- again:
- switch (*proto++) {
- case '[':
- if (contextclass++ == 0) {
- e = strchr(proto, ']');
- if (!e || e == proto)
- goto oops;
- }
- else
- goto oops;
- goto again;
- break;
- case ']':
- if (contextclass) {
- const char *p = proto;
- const char *const end = proto;
- contextclass = 0;
- while (*--p != '[') {}
- bad_type(arg, Perl_form(aTHX_ "one of %.*s",
- (int)(end - p), p),
- gv_ename(namegv), o3);
- } else
- goto oops;
- break;
- case '*':
- if (o3->op_type == OP_RV2GV)
- goto wrapref;
- if (!contextclass)
- bad_type(arg, "symbol", gv_ename(namegv), o3);
- break;
- case '&':
- if (o3->op_type == OP_ENTERSUB)
- goto wrapref;
- if (!contextclass)
- bad_type(arg, "subroutine entry", gv_ename(namegv),
- o3);
- break;
- case '$':
- if (o3->op_type == OP_RV2SV ||
- o3->op_type == OP_PADSV ||
- o3->op_type == OP_HELEM ||
- o3->op_type == OP_AELEM)
- goto wrapref;
- if (!contextclass)
- bad_type(arg, "scalar", gv_ename(namegv), o3);
- break;
- case '@':
- if (o3->op_type == OP_RV2AV ||
- o3->op_type == OP_PADAV)
- goto wrapref;
- if (!contextclass)
- bad_type(arg, "array", gv_ename(namegv), o3);
- break;
- case '%':
- if (o3->op_type == OP_RV2HV ||
- o3->op_type == OP_PADHV)
- goto wrapref;
- if (!contextclass)
- bad_type(arg, "hash", gv_ename(namegv), o3);
- break;
- wrapref:
- {
- OP* const kid = o2;
- OP* const sib = kid->op_sibling;
- kid->op_sibling = 0;
- o2 = newUNOP(OP_REFGEN, 0, kid);
- o2->op_sibling = sib;
- prev->op_sibling = o2;
- }
- if (contextclass && e) {
- proto = e + 1;
- contextclass = 0;
- }
- break;
- default: goto oops;
+ case ']':
+ if (contextclass) {
+ const char *p = proto;
+ const char *const end = proto;
+ contextclass = 0;
+ while (*--p != '[') {}
+ bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+ (int)(end - p), p),
+ gv_ename(namegv), o3);
+ } else
+ goto oops;
+ break;
+ case '*':
+ if (o3->op_type == OP_RV2GV)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "symbol", gv_ename(namegv), o3);
+ break;
+ case '&':
+ if (o3->op_type == OP_ENTERSUB)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "subroutine entry", gv_ename(namegv),
+ o3);
+ break;
+ case '$':
+ if (o3->op_type == OP_RV2SV ||
+ o3->op_type == OP_PADSV ||
+ o3->op_type == OP_HELEM ||
+ o3->op_type == OP_AELEM)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "scalar", gv_ename(namegv), o3);
+ break;
+ case '@':
+ if (o3->op_type == OP_RV2AV ||
+ o3->op_type == OP_PADAV)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "array", gv_ename(namegv), o3);
+ break;
+ case '%':
+ if (o3->op_type == OP_RV2HV ||
+ o3->op_type == OP_PADHV)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "hash", gv_ename(namegv), o3);
+ break;
+ wrapref:
+ {
+ OP* const kid = aop;
+ OP* const sib = kid->op_sibling;
+ kid->op_sibling = 0;
+ aop = newUNOP(OP_REFGEN, 0, kid);
+ aop->op_sibling = sib;
+ prev->op_sibling = aop;
+ }
+ if (contextclass && e) {
+ proto = e + 1;
+ contextclass = 0;
}
- if (contextclass)
- goto again;
break;
- case ' ':
- proto++;
- continue;
- default:
- oops:
- Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), SVfARG(cv));
+ default: goto oops;
}
+ if (contextclass)
+ goto again;
+ break;
+ case ' ':
+ proto++;
+ continue;
+ default:
+ oops:
+ Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
+ gv_ename(namegv), SVfARG(protosv));
+ }
+
+ mod(aop, OP_ENTERSUB);
+ prev = aop;
+ aop = aop->op_sibling;
+ }
+ if (aop == cvop && *proto == '_') {
+ /* generate an access to $_ */
+ aop = newDEFSVOP();
+ aop->op_sibling = prev->op_sibling;
+ prev->op_sibling = aop; /* instead of cvop */
+ }
+ if (!optional && proto_end > proto &&
+ (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
+ return too_few_arguments(entersubop, gv_ename(namegv));
+ return entersubop;
+}
+
+/*
+=for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
+
+Performs the fixup of the arguments part of an C<entersub> op tree either
+based on a subroutine prototype or using default list-context processing.
+This is the standard treatment used on a subroutine call, not marked
+with C<&>, where the callee can be identified at compile time.
+
+I<protosv> supplies the subroutine prototype to be applied to the call,
+or indicates that there is no prototype. It may be a normal scalar,
+in which case if it is defined then the string value will be used
+as a prototype, and if it is undefined then there is no prototype.
+Alternatively, for convenience, it may be a subroutine object (a C<CV*>
+that has been cast to C<SV*>), of which the prototype will be used if it
+has one. The prototype (or lack thereof) supplied, in whichever form,
+does not need to match the actual callee referenced by the op tree.
+
+If the argument ops disagree with the prototype, for example by having
+an unacceptable number of arguments, a valid op tree is returned anyway.
+The error is reflected in the parser state, normally resulting in a single
+exception at the top level of parsing which covers all the compilation
+errors that occurred. In the error message, the callee is referred to
+by the name defined by the I<namegv> parameter.
+
+=cut
+*/
+
+OP *
+Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
+ GV *namegv, SV *protosv)
+{
+ PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
+ if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
+ return ck_entersub_args_proto(entersubop, namegv, protosv);
+ else
+ return ck_entersub_args_list(entersubop);
+}
+
+/*
+=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
+
+Retrieves the function that will be used to fix up a call to I<cv>.
+Specifically, the function is applied to an C<entersub> op tree for a
+subroutine call, not marked with C<&>, where the callee can be identified
+at compile time as I<cv>.
+
+The C-level function pointer is returned in I<*ckfun_p>, and an SV
+argument for it is returned in I<*ckobj_p>. The function is intended
+to be called in this manner:
+
+ entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
+
+In this call, I<entersubop> is a pointer to the C<entersub> op,
+which may be replaced by the check function, and I<namegv> is a GV
+supplying the name that should be used by the check function to refer
+to the callee of the C<entersub> op if it needs to emit any diagnostics.
+It is permitted to apply the check function in non-standard situations,
+such as to a call to a different subroutine or to a method call.
- mod(o2, OP_ENTERSUB);
- prev = o2;
- o2 = o2->op_sibling;
- } /* while */
+By default, the function is
+L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
+and the SV parameter is I<cv> itself. This implements standard
+prototype processing. It can be changed, for a particular subroutine,
+by L</cv_set_call_checker>.
- if (o2 == cvop && *proto == '_') {
- /* generate an access to $_ */
- o2 = newDEFSVOP();
- o2->op_sibling = prev->op_sibling;
- prev->op_sibling = o2; /* instead of cvop */
+=cut
+*/
+
+void
+Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
+{
+ MAGIC *callmg;
+ PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
+ callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
+ if (callmg) {
+ *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
+ *ckobj_p = callmg->mg_obj;
+ } else {
+ *ckfun_p = Perl_ck_entersub_args_proto_or_list;
+ *ckobj_p = (SV*)cv;
+ }
+}
+
+/*
+=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+
+Sets the function that will be used to fix up a call to I<cv>.
+Specifically, the function is applied to an C<entersub> op tree for a
+subroutine call, not marked with C<&>, where the callee can be identified
+at compile time as I<cv>.
+
+The C-level function pointer is supplied in I<ckfun>, and an SV argument
+for it is supplied in I<ckobj>. The function is intended to be called
+in this manner:
+
+ entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
+
+In this call, I<entersubop> is a pointer to the C<entersub> op,
+which may be replaced by the check function, and I<namegv> is a GV
+supplying the name that should be used by the check function to refer
+to the callee of the C<entersub> op if it needs to emit any diagnostics.
+It is permitted to apply the check function in non-standard situations,
+such as to a call to a different subroutine or to a method call.
+
+The current setting for a particular CV can be retrieved by
+L</cv_get_call_checker>.
+
+=cut
+*/
+
+void
+Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
+{
+ PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
+ if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
+ if (SvMAGICAL((SV*)cv))
+ mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
+ } else {
+ MAGIC *callmg;
+ sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
+ callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
+ if (callmg->mg_flags & MGf_REFCOUNTED) {
+ SvREFCNT_dec(callmg->mg_obj);
+ callmg->mg_flags &= ~MGf_REFCOUNTED;
+ }
+ callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
+ callmg->mg_obj = ckobj;
+ if (ckobj != (SV*)cv) {
+ SvREFCNT_inc_simple_void_NN(ckobj);
+ callmg->mg_flags |= MGf_REFCOUNTED;
}
- if (!optional && proto_end > proto &&
- (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
- return too_few_arguments(o, gv_ename(namegv));
}
- return o;
+}
+
+OP *
+Perl_ck_subr(pTHX_ OP *o)
+{
+ OP *aop, *cvop;
+ CV *cv;
+ GV *namegv;
+
+ PERL_ARGS_ASSERT_CK_SUBR;
+
+ aop = cUNOPx(o)->op_first;
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+ aop = aop->op_sibling;
+ for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
+ cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
+ namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
+
+ o->op_private |= OPpENTERSUB_HASTARG;
+ o->op_private |= (PL_hints & HINT_STRICT_REFS);
+ if (PERLDB_SUB && PL_curstash != PL_debstash)
+ o->op_private |= OPpENTERSUB_DB;
+ if (cvop->op_type == OP_RV2CV) {
+ o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
+ op_null(cvop);
+ } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
+ if (aop->op_type == OP_CONST)
+ aop->op_private &= ~OPpCONST_STRICT;
+ else if (aop->op_type == OP_LIST) {
+ OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
+ if (sib && sib->op_type == OP_CONST)
+ sib->op_private &= ~OPpCONST_STRICT;
+ }
+ }
+
+ if (!cv) {
+ return ck_entersub_args_list(o);
+ } else {
+ Perl_call_checker ckfun;
+ SV *ckobj;
+ cv_get_call_checker(cv, &ckfun, &ckobj);
+ return ckfun(aTHX_ o, namegv, ckobj);
+ }
}
OP *
} \
} STMT_END
+/* flags for rv2cv_op_cv */
+
+#define RV2CVOPCV_MARK_EARLY 0x00000001
+#define RV2CVOPCV_RETURN_NAME_GV 0x00000002
+
#ifdef PERL_MAD
# define MAD_NULL 1
# define MAD_PV 2
#define PERL_MAGIC_rhash '%' /* extra data for restricted hashes */
#define PERL_MAGIC_arylen_p '@' /* to move arylen out of XPVAV */
#define PERL_MAGIC_ext '~' /* Available for use by extensions */
+#define PERL_MAGIC_checkcall ']' /* inlining/mutation of call to this CV */
#if defined(DEBUGGING) && defined(I_ASSERT)
# include <assert.h>
#define PERL_ARGS_ASSERT_CK_EACH \
assert(o)
+PERL_CALLCONV OP* Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST \
+ assert(entersubop)
+
+PERL_CALLCONV OP* Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO \
+ assert(entersubop); assert(namegv); assert(protosv)
+
+PERL_CALLCONV OP* Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST \
+ assert(entersubop); assert(namegv); assert(protosv)
+
PERL_CALLCONV OP * Perl_ck_eof(pTHX_ OP *o)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
PERL_CALLCONV SV* Perl_cv_const_sv(pTHX_ const CV *const cv)
__attribute__warn_unused_result__;
+PERL_CALLCONV void Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER \
+ assert(cv); assert(ckfun_p); assert(ckobj_p)
+
+PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER \
+ assert(cv); assert(ckfun); assert(ckobj)
+
PERL_CALLCONV void Perl_cv_undef(pTHX_ CV* cv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_CV_UNDEF \
#define PERL_ARGS_ASSERT_MG_FREE \
assert(sv)
+PERL_CALLCONV void Perl_mg_free_type(pTHX_ SV* sv, int how)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MG_FREE_TYPE \
+ assert(sv)
+
PERL_CALLCONV int Perl_mg_get(pTHX_ SV* sv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_MG_GET \
PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o, CV* cv)
__attribute__warn_unused_result__;
+PERL_CALLCONV OP* Perl_op_contextualize(pTHX_ OP* o, I32 context)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_CONTEXTUALIZE \
+ assert(o)
+
PERL_CALLCONV void Perl_op_dump(pTHX_ const OP *o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_OP_DUMP \
PERL_CALLCONV Sighandler_t Perl_rsignal_state(pTHX_ int i);
PERL_CALLCONV int Perl_runops_debug(pTHX);
PERL_CALLCONV int Perl_runops_standard(pTHX);
+PERL_CALLCONV CV* Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_RV2CV_OP_CV \
+ assert(cvop)
+
PERL_CALLCONV void Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
case PERL_MAGIC_rhash:
case PERL_MAGIC_symtab:
case PERL_MAGIC_vstring:
+ case PERL_MAGIC_checkcall:
vtable = NULL;
break;
case PERL_MAGIC_utf8:
if (len)
goto safe_bareword;
- cv = NULL;
{
OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc(sv));
const_op->op_private = OPpCONST_BARE;
rv2cv_op = newCVREF(0, const_op);
}
- if (rv2cv_op->op_type == OP_RV2CV &&
- (rv2cv_op->op_flags & OPf_KIDS)) {
- OP *rv_op = cUNOPx(rv2cv_op)->op_first;
- switch (rv_op->op_type) {
- case OP_CONST: {
- SV *sv = cSVOPx_sv(rv_op);
- if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
- cv = (CV*)SvRV(sv);
- } break;
- case OP_GV: {
- GV *gv = cGVOPx_gv(rv_op);
- CV *maybe_cv = GvCVu(gv);
- if (maybe_cv && SvTYPE((SV*)maybe_cv) == SVt_PVCV)
- cv = maybe_cv;
- } break;
- }
- }
+ cv = rv2cv_op_cv(rv2cv_op, 0);
/* See if it's the indirect object for a list operator. */
https://perl5.git.perl.org / perl5.git / commitdiff