In perl.git, the branch blead has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/367917954ddd5b3c7085e1a814b02065191c7c38?hp=205ccfbcf5eebeeb73bce7d681468bd3e00c4dbc>

- Log -----------------------------------------------------------------
commit 367917954ddd5b3c7085e1a814b02065191c7c38
Author: Zefram <zef...@fysh.org>
Date:   Tue Aug 8 21:37:46 2017 +0100

    test cv_[gs]et_call_checker_flags()

M       ext/XS-APItest/APItest.pm
M       ext/XS-APItest/APItest.xs

commit a83b92fa8845fe243b594cefd53ec906a9de17a6
Author: Zefram <zef...@fysh.org>
Date:   Tue Aug 8 20:06:11 2017 +0100

    use cv_set_call_checker_flags() where possible
    
    Call checkers established by core code were being set through
    cv_set_call_checker(), so requiring GVs to be created in some cases where
    they could be avoided.  Make all the checkers non-GV-namegv capable,
    and set them with cv_set_call_checker_flags().
    
    The checkers for Devel::Peek::Dump() and
    utf8::{unicode_to_native,native_to_unicode}() were already fit to handle
    non-GV names, so required no changes.  The checker for CORE:: subs,
    ck_entersub_args_core(), was naughtily using the name to decide which sub
    it was dealing with in some cases, so move that information into the ckobj
    that was already being used to identify the sub in most cases.  It also
    required reformulation of some error reporting code to use cv_name().

M       ext/Devel-Peek/Peek.pm
M       ext/Devel-Peek/Peek.xs
M       gv.c
M       op.c
M       universal.c

commit 71c697dea4f5a96ca9a9867eef07455c74f502f5
Author: Zefram <zef...@fysh.org>
Date:   Tue Aug 8 13:30:01 2017 +0100

    add cv_get_call_checker_flags()
    
    The new cv_get_call_checker_flags() is the obvious counterpart to
    the existing cv_set_call_checker_flags(), which was added without
    providing any public way to retrieve the flag state.  Not only does
    cv_get_call_checker_flags() return the CALL_CHECKER_REQUIRE_GV flag
    state, it also takes a flags parameter as an input, to allow for
    future expansion.  The gflags input can at minimum be used for the
    caller to indicate which flags it understands, if more checker flags
    are added in the future, in case such flags are not ignorable in
    the way that CALL_CHECKER_REQUIRE_GV is.  In this commit the gflags
    parameter is applied to indicate whether the caller understands the
    CALL_CHECKER_REQUIRE_GV flag, or more precisely (due to the funny inverted
    sense of the flag) whether it understands the flag being clear.  This use
    of gflags isn't really necessary, but establishes the pattern of usage.

M       embed.fnc
M       embed.h
M       op.c
M       proto.h
-----------------------------------------------------------------------

Summary of changes:
 embed.fnc                 |   3 +-
 embed.h                   |   1 +
 ext/Devel-Peek/Peek.pm    |   2 +-
 ext/Devel-Peek/Peek.xs    |   2 +-
 ext/XS-APItest/APItest.pm |   2 +-
 ext/XS-APItest/APItest.xs |  55 ++++++++++++++++------
 gv.c                      |  11 +++--
 op.c                      | 114 +++++++++++++++++++++++++++++++---------------
 proto.h                   |   5 +-
 universal.c               |   8 ++--
 10 files changed, 139 insertions(+), 64 deletions(-)

diff --git a/embed.fnc b/embed.fnc
index 77e898de9b..00efda994f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1178,10 +1178,11 @@ Apd     |OP*    |ck_entersub_args_proto_or_list|NN OP 
*entersubop|NN GV *namegv|NN SV *
 po     |OP*    |ck_entersub_args_core|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_get_call_checker_flags|NN CV *cv|U32 gflags|NN 
Perl_call_checker *ckfun_p|NN SV **ckobj_p|NN U32 *ckflags_p
 Apd    |void   |cv_set_call_checker|NN CV *cv|NN Perl_call_checker ckfun|NN SV 
*ckobj
 Apd    |void   |cv_set_call_checker_flags|NN CV *cv \
                                          |NN Perl_call_checker ckfun \
-                                         |NN SV *ckobj|U32 flags
+                                         |NN SV *ckobj|U32 ckflags
 Apd    |void   |wrap_op_checker|Optype opcode|NN Perl_check_t new_checker|NN 
Perl_check_t *old_checker_p
 ApR    |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
 Ap     |char*  |scan_vstring   |NN const char *s|NN const char *const e \
diff --git a/embed.h b/embed.h
index cbef9aa265..3765648978 100644
--- a/embed.h
+++ b/embed.h
@@ -104,6 +104,7 @@
 #define cv_clone(a)            Perl_cv_clone(aTHX_ a)
 #define cv_const_sv            Perl_cv_const_sv
 #define cv_get_call_checker(a,b,c)     Perl_cv_get_call_checker(aTHX_ a,b,c)
+#define cv_get_call_checker_flags(a,b,c,d,e)   
Perl_cv_get_call_checker_flags(aTHX_ a,b,c,d,e)
 #define cv_name(a,b,c)         Perl_cv_name(aTHX_ a,b,c)
 #define cv_set_call_checker(a,b,c)     Perl_cv_set_call_checker(aTHX_ a,b,c)
 #define cv_set_call_checker_flags(a,b,c,d)     
Perl_cv_set_call_checker_flags(aTHX_ a,b,c,d)
diff --git a/ext/Devel-Peek/Peek.pm b/ext/Devel-Peek/Peek.pm
index 4ce8b4531b..3d790e763a 100644
--- a/ext/Devel-Peek/Peek.pm
+++ b/ext/Devel-Peek/Peek.pm
@@ -3,7 +3,7 @@
 
 package Devel::Peek;
 
-$VERSION = '1.26';
+$VERSION = '1.27';
 $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
diff --git a/ext/Devel-Peek/Peek.xs b/ext/Devel-Peek/Peek.xs
index cde3e51dec..8a8c0b96d7 100644
--- a/ext/Devel-Peek/Peek.xs
+++ b/ext/Devel-Peek/Peek.xs
@@ -444,7 +444,7 @@ BOOT:
 {
     CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0);
     assert(cv);
-    cv_set_call_checker(cv, S_ck_dump, (SV *)cv);
+    cv_set_call_checker_flags(cv, S_ck_dump, (SV *)cv, 0);
     Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop);
 }
 
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 7de08ad13e..796605f7c0 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '0.90';
+our $VERSION = '0.91';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 23e698c337..7a18bbf291 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -15,7 +15,8 @@ typedef SV *SVREF;
 typedef PTR_TBL_t *XS__APItest__PtrTable;
 
 #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
-#define croak_fail_ne(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), 
(w), __LINE__)
+#define croak_fail_nep(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), 
(w), __LINE__)
+#define croak_fail_nei(h, w) croak("fail %d!=%d at " __FILE__ " line %d", 
(int)(h), (int)(w), __LINE__)
 
 #ifdef EBCDIC
 
@@ -3088,34 +3089,60 @@ test_cv_getset_call_checker()
        CV *troc_cv, *tsh_cv;
        Perl_call_checker ckfun;
        SV *ckobj;
+       U32 ckflags;
     CODE:
-#define check_cc(cv, xckfun, xckobj) \
+#define check_cc(cv, xckfun, xckobj, xckflags) \
     do { \
        cv_get_call_checker((cv), &ckfun, &ckobj); \
-       if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); 
\
-       if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); 
\
+       if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), 
xckfun); \
+       if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), 
xckobj); \
+       cv_get_call_checker_flags((cv), CALL_CHECKER_REQUIRE_GV, &ckfun, 
&ckobj, &ckflags); \
+       if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), 
xckfun); \
+       if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), 
xckobj); \
+       if (ckflags != CALL_CHECKER_REQUIRE_GV) croak_fail_nei(ckflags, 
CALL_CHECKER_REQUIRE_GV); \
+       cv_get_call_checker_flags((cv), 0, &ckfun, &ckobj, &ckflags); \
+       if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), 
xckfun); \
+       if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), 
xckobj); \
+       if (ckflags != (xckflags)) croak_fail_nei(ckflags, (xckflags)); \
     } 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);
+       check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
        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);
+       check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, 
CALL_CHECKER_REQUIRE_GV);
        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);
+       check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, 
CALL_CHECKER_REQUIRE_GV);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, 
CALL_CHECKER_REQUIRE_GV);
        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);
+       check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, 
CALL_CHECKER_REQUIRE_GV);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
        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);
+       check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
        if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
        if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
+       cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
+                                   &PL_sv_yes, 0);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, 0);
+       cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
+                                   &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, 
CALL_CHECKER_REQUIRE_GV);
+       cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
+                                   (SV*)tsh_cv, 0);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
+       if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
+       cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
+                                   &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, 
CALL_CHECKER_REQUIRE_GV);
+       cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
+                                   (SV*)tsh_cv, CALL_CHECKER_REQUIRE_GV);
+       check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
+       if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
 #undef check_cc
 
 void
diff --git a/gv.c b/gv.c
index 39782bcb5e..afddfe48a8 100644
--- a/gv.c
+++ b/gv.c
@@ -608,11 +608,12 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
        PL_compcv = oldcompcv;
     }
     if (cv) {
-        SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
-        cv_set_call_checker(
-          cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
-        );
-        SvREFCNT_dec(opnumsv);
+       SV *opnumsv = newSViv(
+           (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
+               (OP_ENTEREVAL | (1<<16))
+           : opnum ? opnum : (((I32)name[2]) << 16));
+        cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
+       SvREFCNT_dec_NN(opnumsv);
     }
 
     return gv;
diff --git a/op.c b/op.c
index e2d2868eeb..e8fbb1eeb0 100644
--- a/op.c
+++ b/op.c
@@ -11929,7 +11929,8 @@ Perl_ck_entersub_args_proto_or_list(pTHX_ OP 
*entersubop,
 OP *
 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
 {
-    int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
+    IV cvflags = SvIVX(protosv);
+    int opnum = cvflags & 0xffff;
     OP *aop = cUNOPx(entersubop)->op_first;
 
     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
@@ -11940,11 +11941,14 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV 
*namegv, SV *protosv)
            aop = cUNOPx(aop)->op_first;
        aop = OpSIBLING(aop);
        for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
-       if (aop != cvop)
-           (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
+       if (aop != cvop) {
+           SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
+           yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
+               SVfARG(namesv)), SvUTF8(namesv));
+       }
        
        op_free(entersubop);
-       switch(GvNAME(namegv)[2]) {
+       switch(cvflags >> 16) {
        case 'F': return newSVOP(OP_CONST, 0,
                                        newSVpv(CopFILE(PL_curcop),0));
        case 'L': return newSVOP(
@@ -11997,8 +12001,7 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV 
*namegv, SV *protosv)
             op_sibling_splice(parent, first, -1, NULL);
        op_free(entersubop);
 
-       if (opnum == OP_ENTEREVAL
-        && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
+       if (cvflags == (OP_ENTEREVAL | (1<<16)))
            flags |= OPpEVAL_BYTES <<8;
        
        switch (PL_opargs[opnum] & OA_CLASS_MASK) {
@@ -12008,7 +12011,9 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV 
*namegv, SV *protosv)
            return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
        case OA_BASEOP:
            if (aop) {
-                   (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
+               SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
+               yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
+                   SVfARG(namesv)), SvUTF8(namesv));
                op_free(aop);
            }
            return opnum == OP_RUNCV
@@ -12023,70 +12028,101 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV 
*namegv, SV *protosv)
 }
 
 /*
-=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV 
**ckobj_p
+=for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 
gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
 
 Retrieves the function that will be used to fix up a call to C<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 C<cv>.
 
-The C-level function pointer is returned in C<*ckfun_p>, and an SV
-argument for it is returned in C<*ckobj_p>.  The function is intended
-to be called in this manner:
+The C-level function pointer is returned in C<*ckfun_p>, an SV argument
+for it is returned in C<*ckobj_p>, and control flags are returned in
+C<*ckflags_p>.  The function is intended to be called in this manner:
 
  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
 
 In this call, C<entersubop> is a pointer to the C<entersub> op,
-which may be replaced by the check function, and C<namegv> is a GV
-supplying the name that should be used by the check function to refer
+which may be replaced by the check function, and C<namegv> supplies
+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
+C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
+bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
+instead, anything that can be used as the first argument to L</cv_name>.
+If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
+check function requires C<namegv> to be a genuine GV.
+
+By default, the check function is
 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
-and the SV parameter is C<cv> itself.  This implements standard
-prototype processing.  It can be changed, for a particular subroutine,
-by L</cv_set_call_checker>.
+the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
+flag is clear.  This implements standard prototype processing.  It can
+be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
+
+If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
+indicates that the caller only knows about the genuine GV version of
+C<namegv>, and accordingly the corresponding bit will always be set in
+C<*ckflags_p>, regardless of the check function's recorded requirements.
+If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
+indicates the caller knows about the possibility of passing something
+other than a GV as C<namegv>, and accordingly the corresponding bit may
+be either set or clear in C<*ckflags_p>, indicating the check function's
+recorded requirements.
+
+C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
+only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
+(for which see above).  All other bits should be clear.
+
+=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV 
**ckobj_p
+
+The original form of L</cv_get_call_checker_flags>, which does not return
+checker flags.  When using a checker function returned by this function,
+it is only safe to call it with a genuine GV as its C<namegv> argument.
 
 =cut
 */
 
-static void
-S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
-                     U8 *flagsp)
+void
+Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
+       Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
 {
     MAGIC *callmg;
+    PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
+    PERL_UNUSED_CONTEXT;
     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;
-       if (flagsp) *flagsp = callmg->mg_flags;
+       *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
     } else {
        *ckfun_p = Perl_ck_entersub_args_proto_or_list;
        *ckobj_p = (SV*)cv;
-       if (flagsp) *flagsp = 0;
+       *ckflags_p = gflags & MGf_REQUIRE_GV;
     }
 }
 
 void
 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV 
**ckobj_p)
 {
+    U32 ckflags;
     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
     PERL_UNUSED_CONTEXT;
-    S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
+    cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
+       &ckflags);
 }
 
 /*
-=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker 
ckfun|SV *ckobj|U32 flags
+=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker 
ckfun|SV *ckobj|U32 ckflags
 
 Sets the function that will be used to fix up a call to C<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 C<cv>.
 
-The C-level function pointer is supplied in C<ckfun>, and an SV argument
-for it is supplied in C<ckobj>.  The function should be defined like this:
+The C-level function pointer is supplied in C<ckfun>, an SV argument for
+it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
+The function should be defined like this:
 
     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
 
@@ -12104,15 +12140,21 @@ such as to a call to a different subroutine or to a 
method call.
 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
 CV or other SV instead.  Whatever is passed can be used as the first
 argument to L</cv_name>.  You can force perl to pass a GV by including
-C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
+C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
+
+C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
+bit currently has a defined meaning (for which see above).  All other
+bits should be clear.
 
 The current setting for a particular CV can be retrieved by
-L</cv_get_call_checker>.
+L</cv_get_call_checker_flags>.
 
 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV 
*ckobj
 
 The original form of L</cv_set_call_checker_flags>, which passes it the
-C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
+C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
+of that flag setting is that the check function is guaranteed to get a
+genuine GV as its C<namegv> argument.
 
 =cut
 */
@@ -12126,7 +12168,7 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, 
Perl_call_checker ckfun, SV *ckobj)
 
 void
 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
-                                    SV *ckobj, U32 flags)
+                                    SV *ckobj, U32 ckflags)
 {
     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
@@ -12148,7 +12190,7 @@ Perl_cv_set_call_checker_flags(pTHX_ CV *cv, 
Perl_call_checker ckfun,
            callmg->mg_flags |= MGf_REFCOUNTED;
        }
        callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
-                        | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
+                        | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
     }
 }
 
@@ -12229,8 +12271,8 @@ Perl_ck_subr(pTHX_ OP *o)
     } else {
        Perl_call_checker ckfun;
        SV *ckobj;
-       U8 flags;
-       S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
+       U32 ckflags;
+       cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
        if (CvISXSUB(cv) || !CvROOT(cv))
            S_entersub_alloc_targ(aTHX_ o);
        if (!namegv) {
@@ -12240,7 +12282,7 @@ Perl_ck_subr(pTHX_ OP *o)
               the CV’s GV, unless this is an anonymous sub.  This is not
               ideal for lexical subs, as its stringification will include
               the package.  But it is the best we can do.  */
-           if (flags & MGf_REQUIRE_GV) {
+           if (ckflags & CALL_CHECKER_REQUIRE_GV) {
                if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
                    namegv = CvGV(cv);
            }
@@ -15458,8 +15500,8 @@ something like this:
        wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
 
 If you want to influence compilation of calls to a specific subroutine,
-then use L</cv_set_call_checker> rather than hooking checking of all
-C<entersub> ops.
+then use L</cv_set_call_checker_flags> rather than hooking checking of
+all C<entersub> ops.
 
 =cut
 */
diff --git a/proto.h b/proto.h
index e667d4f255..f3f2250cfb 100644
--- a/proto.h
+++ b/proto.h
@@ -654,13 +654,16 @@ PERL_CALLCONV void        Perl_cv_forget_slab(pTHX_ CV 
*cv);
 PERL_CALLCONV void     Perl_cv_get_call_checker(pTHX_ CV *cv, 
Perl_call_checker *ckfun_p, SV **ckobj_p);
 #define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER   \
        assert(cv); assert(ckfun_p); assert(ckobj_p)
+PERL_CALLCONV void     Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 
gflags, Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p);
+#define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS     \
+       assert(cv); assert(ckfun_p); assert(ckobj_p); assert(ckflags_p)
 PERL_CALLCONV SV *     Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags);
 #define PERL_ARGS_ASSERT_CV_NAME       \
        assert(cv)
 PERL_CALLCONV void     Perl_cv_set_call_checker(pTHX_ CV *cv, 
Perl_call_checker ckfun, SV *ckobj);
 #define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER   \
        assert(cv); assert(ckfun); assert(ckobj)
-PERL_CALLCONV void     Perl_cv_set_call_checker_flags(pTHX_ CV *cv, 
Perl_call_checker ckfun, SV *ckobj, U32 flags);
+PERL_CALLCONV void     Perl_cv_set_call_checker_flags(pTHX_ CV *cv, 
Perl_call_checker ckfun, SV *ckobj, U32 ckflags);
 #define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS     \
        assert(cv); assert(ckfun); assert(ckobj)
 PERL_CALLCONV void     Perl_cv_undef(pTHX_ CV* cv);
diff --git a/universal.c b/universal.c
index 6ee65a6a11..65477fb775 100644
--- a/universal.c
+++ b/universal.c
@@ -1089,12 +1089,12 @@ Perl_boot_core_UNIVERSAL(pTHX)
         CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
         CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
 
-        cv_set_call_checker(to_native_cv,
+        cv_set_call_checker_flags(to_native_cv,
                             optimize_out_native_convert_function,
-                            (SV*) to_native_cv);
-        cv_set_call_checker(to_unicode_cv,
+                            (SV*) to_native_cv, 0);
+        cv_set_call_checker_flags(to_unicode_cv,
                             optimize_out_native_convert_function,
-                            (SV*) to_unicode_cv);
+                            (SV*) to_unicode_cv, 0);
     }
 #endif
 

--
Perl5 Master Repository

Reply via email to