Add cv_set_call_checker_flags

This is like cv_set_call_checker, except that it allows the caller to
decide whether the call checker needs a GV.

Currently the GV flag is recorded, but ck_subr does not do anything
with it yet.

diff --git a/cv.h b/cv.h
index c060cab..c1f4456 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -268,6 +268,8 @@ should print 123:
 
 typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);
 
+#define CALL_CHECKER_REQUIRE_GV        MGf_REQUIRE_GV
+
 /*
  * Local variables:
  * c-indentation-style: bsd

diff --git a/embed.fnc b/embed.fnc
index 4378152..d65b22c 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1036,6 +1036,9 @@ 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_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
 Apd    |void   |wrap_op_checker|Optype opcode|NN Perl_check_t new_checker|NN Perl_check_t *old_checker_p
 Apa    |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 8293d49..9cf60c9 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -102,6 +102,7 @@
 #define cv_get_call_checker(a,b,c)     Perl_cv_get_call_checker(aTHX_ a,b,c)
 #define cv_name(a,b)           Perl_cv_name(aTHX_ a,b)
 #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)
 #define cv_undef(a)            Perl_cv_undef(aTHX_ a)
 #define cx_dump(a)             Perl_cx_dump(aTHX_ a)
 #define cxinc()                        Perl_cxinc(aTHX)

diff --git a/mg.h b/mg.h
index 81ed296..0f2fa29 100644 (file)
--- a/mg.h
+++ b/mg.h
@@ -33,6 +33,7 @@ struct magic {
 
 #define MGf_TAINTEDDIR 1        /* PERL_MAGIC_envelem only */
 #define MGf_MINMATCH   1        /* PERL_MAGIC_regex_global only */
+#define MGf_REQUIRE_GV 1        /* PERL_MAGIC_checkcall only */
 #define MGf_REFCOUNTED 2
 #define MGf_GSKIP      4       /* skip further GETs until after next SET */
 #define MGf_COPY       8       /* has an svt_copy  MGVTBL entry */

diff --git a/op.c b/op.c
index b08ddcd..fa4b8e6 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10764,7 +10764,7 @@ Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
 }
 
 /*
-=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
 
 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
@@ -10781,15 +10781,25 @@ It 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
+which may be replaced by the check function, and I<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.
 
+I<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 I<flags>.
+
 The current setting for a particular CV can be retrieved by
 L</cv_get_call_checker>.
 
+=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.
+
 =cut
 */
 
@@ -10797,6 +10807,14 @@ void
 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
 {
     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
+    cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
+}
+
+void
+Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
+                                    SV *ckobj, U32 flags)
+{
+    PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
        if (SvMAGICAL((SV*)cv))
            mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
@@ -10815,7 +10833,8 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
            SvREFCNT_inc_simple_void_NN(ckobj);
            callmg->mg_flags |= MGf_REFCOUNTED;
        }
-       callmg->mg_flags |= MGf_COPY;
+       callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
+                        | (flags & MGf_REQUIRE_GV) | MGf_COPY;
     }
 }
 

diff --git a/proto.h b/proto.h
index a540fc7..e12b8a7 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -823,6 +823,13 @@ PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfu
 #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)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS     \
+       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      \