+ 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.
+
+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>.
+
+=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;
+ }
+ }
+}
+
+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);