plugin mechanism to rewrite calls to a subroutine

New magic type PERL_MAGIC_checkcall attaches a function to a CV, which
will be called as the second half of the op checker for an entersub
op calling that CV.  Default state, in the absence of this magic,
is to process the CV's prototype if it has one, or apply list context
to all the arguments if not.  New API functions cv_get_call_checker()
and cv_set_call_checker() provide a clean interface to this facility,
hiding the internal use of magic.

Expose in the API the new functions rv2cv_op_cv(),
ck_entersub_args_list(), ck_entersub_args_proto(), and
ck_entersub_args_proto_or_list(), which are meaningful segments of
standard entersub op checking and are likely to be useful in plugged-in
call checker functions.

Expose new API function op_contextualize(), which is a public interface
to the internal scalar()/list()/scalarvoid() functions.  This API is
likely to be required in most plugged-in call checker functions.

Incidentally add new function mg_free_type(), in the API, which will
remove magic of one type from an SV.  (mg_free() removes all magic,
and there isn't anything else more selective.)

18 files changed, 1123 insertions, 275 deletions

diff --git a/MANIFEST b/MANIFEST
index 8c10366199..064993d942 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3374,6 +3374,7 @@ ext/XS-APItest/t/BHK.pm		Helper for ./blockhooks.t
 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
@@ -3383,10 +3384,12 @@ 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
 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()
@@ -3394,6 +3397,7 @@ ext/XS-APItest/t/printf.t	XS::APItest extension
 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
diff --git a/cv.h b/cv.h
index 7979a05c80..e6f5cba9c6 100644
--- a/cv.h
+++ b/cv.h
@@ -192,6 +192,8 @@ should print 123:
 =cut
 */
 
+typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);
+
 /*
  * Local variables:
  * c-indentation-style: bsd
diff --git a/dump.c b/dump.c
index 636bcad583..f7fc0147ec 100644
--- a/dump.c
+++ b/dump.c
@@ -1248,6 +1248,7 @@ static const struct { const char type; const char *name; } magic_names[] = {
 	{ 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)" },
diff --git a/embed.fnc b/embed.fnc
index 5741ef040e..d64b268345 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -728,6 +728,7 @@ Apd	|int	|mg_copy	|NN SV *sv|NN SV *nsv|NULLOK const char *key \
 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
@@ -844,6 +845,12 @@ Apda	|OP*	|newWHENOP	|NULLOK OP* cond|NN OP* block
 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
@@ -1085,6 +1092,7 @@ s	|void	|save_pushptri32ptr|NULLOK void *const ptr1|const I32 i \
 #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)
diff --git a/embed.h b/embed.h
index 0e06f08ccb..f4d01f1922 100644
--- a/embed.h
+++ b/embed.h
@@ -59,6 +59,9 @@
 #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
@@ -74,6 +77,8 @@
 #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)
@@ -273,6 +278,7 @@
 #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)
@@ -358,6 +364,7 @@
 #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)
@@ -409,6 +416,7 @@
 #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
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index b59aff45d9..b0cbf6acbf 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -372,6 +372,50 @@ my_rpeep (pTHX_ OP *o)
     }
 }
 
+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)
@@ -1461,6 +1505,221 @@ bhk_record(bool on)
             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;
diff --git a/ext/XS-APItest/t/call_checker.t b/ext/XS-APItest/t/call_checker.t
new file mode 100644
index 0000000000..51dbc939a4
--- /dev/null
+++ b/ext/XS-APItest/t/call_checker.t
@@ -0,0 +1,161 @@
+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;
diff --git a/ext/XS-APItest/t/magic_chain.t b/ext/XS-APItest/t/magic_chain.t
new file mode 100644
index 0000000000..3c24853e87
--- /dev/null
+++ b/ext/XS-APItest/t/magic_chain.t
@@ -0,0 +1,10 @@
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+XS::APItest::test_magic_chain();
+ok 1;
+
+1;
diff --git a/ext/XS-APItest/t/op_contextualize.t b/ext/XS-APItest/t/op_contextualize.t
new file mode 100644
index 0000000000..8c085796f1
--- /dev/null
+++ b/ext/XS-APItest/t/op_contextualize.t
@@ -0,0 +1,10 @@
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+XS::APItest::test_op_contextualize();
+ok 1;
+
+1;
diff --git a/ext/XS-APItest/t/rv2cv_op_cv.t b/ext/XS-APItest/t/rv2cv_op_cv.t
new file mode 100644
index 0000000000..0d54ba90e8
--- /dev/null
+++ b/ext/XS-APItest/t/rv2cv_op_cv.t
@@ -0,0 +1,10 @@
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+XS::APItest::test_rv2cv_op_cv();
+ok 1;
+
+1;
diff --git a/global.sym b/global.sym
index 203affb52c..d7b479621c 100644
--- a/global.sym
+++ b/global.sym
@@ -54,6 +54,9 @@ Perl_cast_i32
 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
@@ -67,6 +70,8 @@ Perl_croak_xs_usage
 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
@@ -302,6 +307,7 @@ Perl_mg_clear
 Perl_mg_copy
 Perl_mg_find
 Perl_mg_free
+Perl_mg_free_type
 Perl_mg_get
 Perl_mg_length
 Perl_mg_magical
@@ -403,6 +409,7 @@ Perl_new_warnings_bitfield
 Perl_ninstr
 Perl_nothreadhook
 Perl_op_clear
+Perl_op_contextualize
 Perl_op_dump
 Perl_op_free
 Perl_op_null
@@ -474,6 +481,7 @@ Perl_rsignal
 Perl_rsignal_state
 Perl_runops_debug
 Perl_runops_standard
+Perl_rv2cv_op_cv
 Perl_safesyscalloc
 Perl_safesysfree
 Perl_safesysmalloc
diff --git a/mg.c b/mg.c
index 8b283d993e..b96a1c1262 100644
--- a/mg.c
+++ b/mg.c
@@ -179,6 +179,7 @@ S_is_container_magic(const MAGIC *mg)
     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;
@@ -522,6 +523,24 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
     }	    
 }
 
+#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
 
@@ -539,19 +558,8 @@ Perl_mg_free(pTHX_ SV *sv)
     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);
@@ -559,6 +567,39 @@ Perl_mg_free(pTHX_ SV *sv)
     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
diff --git a/op.c b/op.c
index 10279babc5..86b933fdae 100644
--- a/op.c
+++ b/op.c
@@ -818,6 +818,31 @@ Perl_op_refcnt_unlock(pTHX)
 
 /* 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 *
@@ -8401,276 +8426,539 @@ Perl_ck_join(pTHX_ OP *o)
     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 *
diff --git a/op.h b/op.h
index a29d516d10..e03468fc4b 100644
--- a/op.h
+++ b/op.h
@@ -741,6 +741,11 @@ preprocessing token; the type of I<arg> depends on I<which>.
 	} \
     } 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
diff --git a/perl.h b/perl.h
index 4cfb29c82d..a680e763ce 100644
--- a/perl.h
+++ b/perl.h
@@ -3901,6 +3901,7 @@ Gid_t getegid (void);
 #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>
diff --git a/proto.h b/proto.h
index bb8927228e..48d63608cd 100644
--- a/proto.h
+++ b/proto.h
@@ -288,6 +288,25 @@ PERL_CALLCONV OP *	Perl_ck_each(pTHX_ OP *o)
 #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);
@@ -584,6 +603,20 @@ PERL_CALLCONV CV*	Perl_cv_clone(pTHX_ CV* proto)
 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	\
@@ -2146,6 +2179,11 @@ PERL_CALLCONV int	Perl_mg_free(pTHX_ SV* sv)
 #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	\
@@ -2650,6 +2688,11 @@ PERL_CALLCONV void	Perl_op_clear(pTHX_ OP* o)
 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	\
@@ -3393,6 +3436,11 @@ PERL_CALLCONV int	Perl_rsignal_save(pTHX_ int i, Sighandler_t t1, Sigsave_t* sav
 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);
diff --git a/sv.c b/sv.c
index 1c8d6dd979..106fc1842f 100644
--- a/sv.c
+++ b/sv.c
@@ -5203,6 +5203,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     case PERL_MAGIC_rhash:
     case PERL_MAGIC_symtab:
     case PERL_MAGIC_vstring:
+    case PERL_MAGIC_checkcall:
 	vtable = NULL;
 	break;
     case PERL_MAGIC_utf8:
diff --git a/toke.c b/toke.c
index 832b9e9b6a..b223ea4f3d 100644
--- a/toke.c
+++ b/toke.c
@@ -6340,29 +6340,12 @@ Perl_yylex(pTHX)
 		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. */