lexical subs don't seem to honor prototypes #12767
Comments
From PeterCMartini@GMail.comCreated by petercmartini@gmail.comlexical subs don't seem to honor prototypes: perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;' Get rid of the 'my', and that dies. Perl Info |
From PeterCMartini@GMail.comSo, this is because prototype handling operates on an rv pointing to a Fixing that gets to this little bit of ugliness, as explained in op.c: if (!namegv) { /* expletive! */ I'm not sure what the best way forward is here. |
From [Unknown Contact. See original ticket]So, this is because prototype handling operates on an rv pointing to a Fixing that gets to this little bit of ugliness, as explained in op.c: if (!namegv) { /* expletive! */ I'm not sure what the best way forward is here. |
|
PeterCMartini@GMail.com - Status changed from 'new' to 'open' |
From PeterCMartini@GMail.comThe tests for lexical subs (t/cmd/lexsub.t) includes this: package main; That last test seems like a bug rather than a feature, and is part of If we can agree that that test should also return '$', then I can submit It's a rather involved patch... |
From [Unknown Contact. See original ticket]The tests for lexical subs (t/cmd/lexsub.t) includes this: package main; That last test seems like a bug rather than a feature, and is part of If we can agree that that test should also return '$', then I can submit It's a rather involved patch... |
From @rgarciaOn 17 February 2013 06:36, Peter Martini via RT
In any event, I think that either 5.18 should have lexical-sub |
From PeterCMartini@GMail.comOn Mon, Feb 18, 2013 at 3:47 AM, Rafael Garcia-Suarez <rgs@consttype.org> wrote:
We're in good shape on that point: perl5.17.9 -E 'my sub foo {say @_} foo 1;' perl5.17.9 -Mfeature=lexical_subs -E 'my sub foo {say @_} foo 1;' It warns no matter what, but doesn't even execute unless you |
From PeterCMartini@GMail.comOn Tue Feb 12 20:53:03 2013, pcm wrote:
PATH=/usr/lib/lightdm/lightdm:/usr/local/sbin:/usr/local/bin:/usr/sbin:/
Further testing: perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;' Does not check prototypes. perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a(1);' *Does* check prototypes. The difference is the second one generates an rv2cv pointing to the I'd been playing with ways to fix this, and checked in my work-in- There are two components, which are separable: 1. Change ck_subr to grab the CV directly from padcv if that's the last 2. Father C had noted that the Perl_call_checker API passes a GV*, which I added an alternate API, Perl_call_checker_sv and appropriate get/set These both get stored in checkcall magic, so only one can be active at a ************ Now that I see that prototypes are actually partially honored, applying |
From [Unknown Contact. See original ticket]On Tue Feb 12 20:53:03 2013, pcm wrote:
PATH=/usr/lib/lightdm/lightdm:/usr/local/sbin:/usr/local/bin:/usr/sbin:/
Further testing: perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;' Does not check prototypes. perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a(1);' *Does* check prototypes. The difference is the second one generates an rv2cv pointing to the I'd been playing with ways to fix this, and checked in my work-in- There are two components, which are separable: 1. Change ck_subr to grab the CV directly from padcv if that's the last 2. Father C had noted that the Perl_call_checker API passes a GV*, which I added an alternate API, Perl_call_checker_sv and appropriate get/set These both get stored in checkcall magic, so only one can be active at a ************ Now that I see that prototypes are actually partially honored, applying |
From PeterCMartini@GMail.comFather C - This change: Inline Patchdiff --git a/op.c b/op.c
index c9a1b53..9c2d06a 100644
--- a/op.c
+++ b/op.c
@@ -8135,7 +8135,6 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o)
dVAR;
o->op_type = OP_PADCV;
o->op_ppaddr = PL_ppaddr[OP_PADCV];
- return o;
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
'my sub if(){44} if;' # boom! I haven't been able to chase down a fix for that part yet, though. |
From [Unknown Contact. See original ticket]Father C - This change: Inline Patchdiff --git a/op.c b/op.c
index c9a1b53..9c2d06a 100644
--- a/op.c
+++ b/op.c
@@ -8135,7 +8135,6 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o)
dVAR;
o->op_type = OP_PADCV;
o->op_ppaddr = PL_ppaddr[OP_PADCV];
- return o;
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
'my sub if(){44} if;' # boom! I haven't been able to chase down a fix for that part yet, though. |
From @chipdudeOn 2/16/2013 9:36 PM, Peter Martini via RT wrote:
This test seems fine. After all, compare with scalars. While $me Which isn't to say that lexical subs should ignore prototypes. |
From PeterCMartini@GMail.comOn Tue, Feb 19, 2013 at 9:38 PM, Reverend Chip <rev.chip@gmail.com> wrote:
Ah, that makes sense, and proves the point that my original approach Removing the early return in newCVREF certainly looks like a much
|
From @cpansproutOn Mon Feb 18 10:55:41 2013, pcm wrote:
I’ve done what I think is the more correct fix, which is to avoid
Would you be willing to do that? :-) One thing I thought about was to create a new API function, maybe called Whatever value is passed through the new call checker API could be -- Father Chrysostomos |
From @cpansproutOn Tue Feb 19 07:08:56 2013, pcm wrote:
That part I’ve fixed in commit 83a72a1. -- Father Chrysostomos |
From PeterCMartini@GMail.comOn Sun Jun 02 13:36:14 2013, sprout wrote:
If you don't beat me to it, I'll put that on my TODO list :-) |
From @cpansproutOn Sun Jun 02 13:36:14 2013, sprout wrote:
That URL does not work any more.
I was about to do that (separate out part 2 from your patch and polish it up), but, as noted above, cannot access that URL. Do you still have the patch floating around somewhere? If not, I will just have to write it from scratch. I need it right now for the stuff I’m doing on the sprout/cvgv branch. (ck_subr reifies GVs and I need the alternate call checker API to remove the need for that.) -- Father Chrysostomos |
From @cpansproutOn Wed Sep 10 20:39:40 2014, sprout wrote:
Actually, having a separate API that takes an SV* would require us to duplicate all the built-in call checkers. Instead, how about a cv_set_call_checker_flags, and the only flag is CALL_CHECKER_REQUIRE_GV? cv_set_call_checker calls _flags with that flag. The name thingy that gets passed to the call checker can be cast to GV *. -- Father Chrysostomos |
From @rjbs* Father Chrysostomos via RT <perlbug-followup@perl.org> [2014-09-10T23:39:41]
(This is why, even though it can be a pain in the butt, we ask for patches to -- |
From PeterCMartini@GMail.comOn Wed, Sep 10, 2014 at 11:39 PM, Father Chrysostomos via RT
I'm not quite sure at what point that got borked, since my local git |
From @cpansproutOn Thu Sep 11 22:50:24 2014, pcm wrote:
Thank you anyway. Or, rather, thank you for not restoring it till now, because I might not have been prompted by laziness to come up with a simpler solution otherwise. :-) I do think it is over-engineered and that cv_set_call_checker_flags is a better solution. BTW, have you seen what I am doing on the sprout/cvgv branch? It is almost ready for merging, but not quite. Maybe a few more days. In any case, ‘sub foo{} foo() \&foo’ no longer has to create a *foo glob, saving memory. -- Father Chrysostomos |
From @cpansproutOn Thu Sep 11 22:50:24 2014, pcm wrote:
I’m attaching it here for future readers. -- Father Chrysostomos |
From @cpansproutFrom 0229fcb Mon Sep 17 00:00:00 2001 cv.h | 1 + Inline Patchdiff --git a/cv.h b/cv.h
index 5da9a50..4dcc35f 100644
--- a/cv.h
+++ b/cv.h
@@ -268,6 +268,7 @@ should print 123:
*/
typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);
+typedef OP *(*Perl_call_checker_sv)(pTHX_ OP *, SV *, SV *);
/*
* Local variables:
diff --git a/embed.fnc b/embed.fnc
index a288c5a..ed09312 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -977,13 +977,26 @@ Apda |OP* |newWHILEOP |I32 flags|I32 debuggable|NULLOK LOOP* loop \
|NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \
|I32 has_my
Apd |CV* |rv2cv_op_cv |NN OP *cvop|U32 flags
+#if defined(PERL_IN_OP_C)
+s |CV* |padcv_op_cv |NN OP *padcvop|NULLOK SV ** namesv
+#endif
Apd |OP* |ck_entersub_args_list|NN OP *entersubop
Apd |OP* |ck_entersub_args_proto|NN OP *entersubop|NN GV *namegv|NN SV *protosv
+AMpd |OP* |ck_entersub_args_proto_sv|NN OP *entersubop|NN SV *namesv|NN SV *protosv
+#if defined(PERL_IN_OP_C)
+s |OP* |ck_entersub_args_proto_core|NN OP *entersubop|NN void *namev|NN SV *protosv|bool name_is_gv
+#endif
Apd |OP* |ck_entersub_args_proto_or_list|NN OP *entersubop|NN GV *namegv|NN SV *protosv
+AMpd |OP* |ck_entersub_args_proto_or_list_sv|NN OP *entersubop|NN SV *namesv|NN SV *protosv
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
+AMpd |void |cv_get_call_checker_sv|NN CV *cv|NN Perl_call_checker_sv *ckfun_p|NN SV **ckobj_p
Apd |void |cv_set_call_checker|NN CV *cv|NN Perl_call_checker ckfun|NN SV *ckobj
+AMpd |void |cv_set_call_checker_sv|NN CV *cv|NN Perl_call_checker_sv ckfun|NN SV *ckobj
+#if defined(PERL_IN_OP_C)
+s |MAGIC* |cv_set_call_checker_core|NN CV *cv|NN void *ckfun|NN SV *ckobj
+#endif
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 c66eba9..c5154f4 100644
--- a/embed.h
+++ b/embed.h
@@ -77,6 +77,8 @@
#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)
+#define ck_entersub_args_proto_or_list_sv(a,b,c) Perl_ck_entersub_args_proto_or_list_sv(aTHX_ a,b,c)
+#define ck_entersub_args_proto_sv(a,b,c) Perl_ck_entersub_args_proto_sv(aTHX_ a,b,c)
#ifndef PERL_IMPLICIT_CONTEXT
#define ck_warner Perl_ck_warner
#define ck_warner_d Perl_ck_warner_d
@@ -93,7 +95,9 @@
#define cv_clone(a) Perl_cv_clone(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_get_call_checker_sv(a,b,c) Perl_cv_get_call_checker_sv(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_sv(a,b,c) Perl_cv_set_call_checker_sv(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)
@@ -1416,7 +1420,9 @@
#define apply_attrs_my(a,b,c,d) S_apply_attrs_my(aTHX_ a,b,c,d)
#define bad_type_pv(a,b,c,d,e) S_bad_type_pv(aTHX_ a,b,c,d,e)
#define bad_type_sv(a,b,c,d,e) S_bad_type_sv(aTHX_ a,b,c,d,e)
+#define ck_entersub_args_proto_core(a,b,c,d) S_ck_entersub_args_proto_core(aTHX_ a,b,c,d)
#define cop_free(a) S_cop_free(aTHX_ a)
+#define cv_set_call_checker_core(a,b,c) S_cv_set_call_checker_core(aTHX_ a,b,c)
#define dup_attrlist(a) S_dup_attrlist(aTHX_ a)
#define finalize_op(a) S_finalize_op(aTHX_ a)
#define find_and_forget_pmops(a) S_find_and_forget_pmops(aTHX_ a)
@@ -1439,6 +1445,7 @@
#define no_fh_allowed(a) S_no_fh_allowed(aTHX_ a)
#define op_integerize(a) S_op_integerize(aTHX_ a)
#define op_std_init(a) S_op_std_init(aTHX_ a)
+#define padcv_op_cv(a,b) S_padcv_op_cv(aTHX_ a,b)
#define pmtrans(a,b,c) S_pmtrans(aTHX_ a,b,c)
#define process_special_blocks(a,b,c,d) S_process_special_blocks(aTHX_ a,b,c,d)
#define ref_array_or_hash(a) S_ref_array_or_hash(aTHX_ a)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index dbb4f50..58d3c94 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1124,6 +1124,9 @@ my_ck_rv2cv(pTHX_ OP *o)
return old_ck_rv2cv(aTHX_ o);
}
+static OP * my_callchecker(pTHX_ OP *o, GV *g, SV *p) { return o; }
+static OP * my_callchecker_sv(pTHX_ OP *o, SV *g, SV *p) { return o; }
+
#include "const-c.inc"
MODULE = XS::APItest PACKAGE = XS::APItest
@@ -1132,6 +1135,8 @@ INCLUDE: const-xs.inc
INCLUDE: numeric.xs
+INCLUDE: callchecker.xs
+
MODULE = XS::APItest::utf8 PACKAGE = XS::APItest::utf8
int
diff --git a/ext/XS-APItest/callchecker.xs b/ext/XS-APItest/callchecker.xs
new file mode 100644
index 0000000..0cba6dc
--- /dev/null
+++ b/ext/XS-APItest/callchecker.xs
@@ -0,0 +1,51 @@
+MODULE = XS::APItest PACKAGE = XS::APItest::callchecker
+
+UV
+callchecker_address()
+ CODE:
+ RETVAL = PTR2UV(my_callchecker);
+ OUTPUT:
+ RETVAL
+
+UV
+callchecker_sv_address()
+ CODE:
+ RETVAL = PTR2UV(my_callchecker_sv);
+ OUTPUT:
+ RETVAL
+
+void
+setcallchecker(cv)
+ CV * cv
+ CODE:
+ SV * ckobj = (SV *)cv;
+ cv_set_call_checker(cv, my_callchecker, ckobj);
+
+void
+setcallchecker_sv(cv)
+ CV * cv
+ CODE:
+ SV * ckobj = (SV *)cv;
+ cv_set_call_checker_sv(cv, my_callchecker_sv, ckobj);
+
+UV
+getcallchecker(cv)
+ CV * cv
+ CODE:
+ Perl_call_checker ckfun;
+ SV *ckobj;
+ cv_get_call_checker(cv, &ckfun, &ckobj);
+ RETVAL = PTR2UV(ckfun);
+ OUTPUT:
+ RETVAL
+
+UV
+getcallchecker_sv(cv)
+ CV * cv
+ CODE:
+ Perl_call_checker_sv ckfun;
+ SV *ckobj;
+ cv_get_call_checker_sv(cv, &ckfun, &ckobj);
+ RETVAL = PTR2UV(ckfun);
+ OUTPUT:
+ RETVAL
diff --git a/op.c b/op.c
index c9a1b53..c9f64d9 100644
--- a/op.c
+++ b/op.c
@@ -8135,6 +8135,7 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o)
dVAR;
o->op_type = OP_PADCV;
o->op_ppaddr = PL_ppaddr[OP_PADCV];
+ o->op_private = (U8)(1 | flags >> 8);
return o;
}
return newUNOP(OP_RV2CV, flags, scalar(o));
@@ -9890,24 +9891,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
gv = NULL;
} break;
case OP_PADCV: {
- PADNAME *name = PAD_COMPNAME(rvop->op_targ);
- CV *compcv = PL_compcv;
- PADOFFSET off = rvop->op_targ;
- while (PadnameOUTER(name)) {
- assert(PARENT_PAD_INDEX(name));
- compcv = CvOUTSIDE(PL_compcv);
- name = PadlistNAMESARRAY(CvPADLIST(compcv))
- [off = PARENT_PAD_INDEX(name)];
- }
- assert(!PadnameIsOUR(name));
- if (!PadnameIsSTATE(name)) {
- MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
- assert(mg);
- assert(mg->mg_obj);
- cv = (CV *)mg->mg_obj;
- }
- else cv =
- (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
+ cv = padcv_op_cv(rvop, NULL);
gv = NULL;
} break;
default: {
@@ -9925,6 +9909,33 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
}
}
+STATIC CV *
+S_padcv_op_cv(pTHX_ OP *padcvop, SV ** namesv)
+{
+ PADOFFSET off = padcvop->op_targ;
+ PADNAME *name = PAD_COMPNAME(off);
+ CV *compcv = PL_compcv;
+ CV *retcv = NULL;
+ while (PadnameOUTER(name)) {
+ assert(PARENT_PAD_INDEX(name));
+ compcv = CvOUTSIDE(PL_compcv);
+ name = PadlistNAMESARRAY(CvPADLIST(compcv))[off = PARENT_PAD_INDEX(name)];
+ }
+ assert(!PadnameIsOUR(name));
+ if (!PadnameIsSTATE(name)) {
+ MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
+ assert(mg);
+ assert(mg->mg_obj);
+ retcv = (CV *)mg->mg_obj;
+ }
+ else retcv = (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
+ if (namesv)
+ *namesv = sv_2mortal(newSVpvn_utf8(
+ PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
+ ));
+ return retcv;
+}
+
/*
=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
@@ -9986,6 +9997,29 @@ by the name defined by the I<namegv> parameter.
OP *
Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
{
+ PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
+ return ck_entersub_args_proto_core(entersubop, (void *)namegv, protosv, TRUE);
+}
+
+/*
+=for apidoc AMpd|OP *|ck_entersub_args_proto_sv|OP *entersubop|SV *namegv|SV *protosv
+
+An alternative interface for L</ck_entersub_args_proto> which takes a C<SV*>
+instead of a C<GV*>.
+
+=cut
+*/
+
+OP *
+Perl_ck_entersub_args_proto_sv(pTHX_ OP *entersubop, SV *namesv, SV *protosv)
+{
+ PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_SV;
+ return ck_entersub_args_proto_core(entersubop, (void *)namesv, protosv, FALSE);
+}
+
+STATIC OP *
+S_ck_entersub_args_proto_core(pTHX_ OP *entersubop, void *namev, SV *protosv, bool name_is_gv)
+{
STRLEN proto_len;
const char *proto, *proto_end;
OP *aop, *prev, *cvop;
@@ -9993,7 +10027,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
I32 arg = 0;
I32 contextclass = 0;
const char *e = NULL;
- PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
+ SV * namesv = (name_is_gv ? gv_ename((GV *)namev) : (SV *)namev);
if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
"flags=%lx", (unsigned long) SvFLAGS(protosv));
@@ -10019,7 +10053,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
o3 = aop;
if (proto >= proto_end)
- return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
+ return too_many_arguments_sv(entersubop, namesv, 0);
switch (*proto) {
case ';':
@@ -10046,7 +10080,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
bad_type_sv(arg,
arg == 1 ? "block or sub {}" : "sub {}",
- gv_ename(namegv), 0, o3);
+ namesv, 0, o3);
break;
case '*':
/* '*' allows any scalar type, including bareword */
@@ -10133,7 +10167,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
)) goto wrapref;
bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
- gv_ename(namegv), 0, o3);
+ namesv, 0, o3);
} else
goto oops;
break;
@@ -10141,13 +10175,13 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
if (o3->op_type == OP_RV2GV)
goto wrapref;
if (!contextclass)
- bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
+ bad_type_sv(arg, "symbol", namesv, 0, o3);
break;
case '&':
if (o3->op_type == OP_ENTERSUB)
goto wrapref;
if (!contextclass)
- bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
+ bad_type_sv(arg, "subroutine entry", namesv, 0,
o3);
break;
case '$':
@@ -10163,7 +10197,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
OP_READ, /* not entersub */
OP_LVALUE_NO_CROAK
)) goto wrapref;
- bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
+ bad_type_sv(arg, "scalar", namesv, 0, o3);
}
break;
case '@':
@@ -10171,14 +10205,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
o3->op_type == OP_PADAV)
goto wrapref;
if (!contextclass)
- bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
+ bad_type_sv(arg, "array", namesv, 0, o3);
break;
case '%':
if (o3->op_type == OP_RV2HV ||
o3->op_type == OP_PADHV)
goto wrapref;
if (!contextclass)
- bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
+ bad_type_sv(arg, "hash", namesv, 0, o3);
break;
wrapref:
{
@@ -10204,10 +10238,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
continue;
default:
oops: {
- SV* const tmpsv = sv_newmortal();
- gv_efullname3(tmpsv, namegv, NULL);
Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
- SVfARG(tmpsv), SVfARG(protosv));
+ SVfARG(namesv), SVfARG(protosv));
}
}
@@ -10223,7 +10255,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
- return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
+ return too_few_arguments_sv(entersubop, namesv, 0);
return entersubop;
}
@@ -10265,6 +10297,27 @@ Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
return ck_entersub_args_list(entersubop);
}
+/*
+=for apidoc AMpd|OP *|ck_entersub_args_proto_or_list_sv|OP *entersubop|SV *namesv|SV *protosv
+
+Equivalent to L</ck_entersub_args_proto_or_list>, but passes the name of
+the function as an C<SV*> rather than a C<GV*>, since not all functions
+have a C<GV> to store a name.
+
+=cut
+*/
+
+OP *
+Perl_ck_entersub_args_proto_or_list_sv(pTHX_ OP *entersubop,
+ SV *namesv, SV *protosv)
+{
+ PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST_SV;
+ if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
+ return ck_entersub_args_proto_sv(entersubop, namesv, protosv);
+ else
+ return ck_entersub_args_list(entersubop);
+}
+
OP *
Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
{
@@ -10385,6 +10438,26 @@ 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>.
+See L</cv_get_call_checker_sv> for an alternative version which uses
+I<Perl_call_checker_sv> instead of I<Perl_call_checker>.
+
+There are two differences between the functions:
+
+=over 4
+
+=item *
+
+The L</cv_get_call_checker_sv> returns a function which takes
+an C<SV*> instead of a C<GV*> (set by L</cv_get_call_checker_sv>
+
+=item *
+
+L</cv_get_call_checker> will croak if the call checker is not the
+default and is not the right type; L</cv_get_call_checker_sv>
+will set the function pointer to NULL instead.
+
+=back
+
=cut
*/
@@ -10394,9 +10467,20 @@ 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) {
+ if (callmg && callmg->mg_private == 0) {
*ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
*ckobj_p = callmg->mg_obj;
+ } else if (callmg && callmg->mg_private == 1) {
+ /* If it's still set to the default, return the origianl default call checker */
+ if (callmg->mg_ptr == (char *)Perl_ck_entersub_args_proto_or_list_sv) {
+ *ckfun_p = Perl_ck_entersub_args_proto_or_list;
+ *ckobj_p = (SV*)cv;
+ } else {
+ SV *xpt = Perl_newSVpvf(aTHX_
+ "cv_get_call_checker cannot return a value set by cv_get_call_checker_sv");
+ Perl_sv_2mortal(aTHX_ xpt);
+ Perl_croak_sv(aTHX_ xpt);
+ }
} else {
*ckfun_p = Perl_ck_entersub_args_proto_or_list;
*ckobj_p = (SV*)cv;
@@ -10404,6 +10488,65 @@ Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
}
/*
+=for apidoc AMpd|void|cv_get_call_checker_sv|CV *cv|Perl_call_checker_sv *ckfun_p|SV **ckobj_p
+
+See L</cv_get_call_checker> for details.
+
+=cut
+*/
+
+void
+Perl_cv_get_call_checker_sv(pTHX_ CV *cv, Perl_call_checker_sv *ckfun_p, SV **ckobj_p)
+{
+ MAGIC *callmg;
+ PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_SV;
+ callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
+ if (callmg && callmg->mg_private == 1) {
+ *ckfun_p = DPTR2FPTR(Perl_call_checker_sv, callmg->mg_ptr);
+ *ckobj_p = callmg->mg_obj;
+ } else if (callmg && callmg->mg_private == 0) {
+ *ckfun_p = NULL;
+ *ckobj_p = callmg->mg_obj;
+ } else {
+ *ckfun_p = Perl_ck_entersub_args_proto_or_list_sv;
+ *ckobj_p = (SV*)cv;
+ }
+}
+
+/* Utility function for common code between cv_set_call_checker(|_sv) */
+
+STATIC MAGIC *
+S_cv_set_call_checker_core(pTHX_ CV *cv, void *ckfun, SV *ckobj)
+{
+ PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_CORE;
+ 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 if (ckfun == Perl_ck_entersub_args_proto_or_list_sv && ckobj == (SV*)cv) {
+ /* If this version is desired, cv_get_call_checker will return it */
+ 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;
+ }
+ callmg->mg_flags |= MGf_COPY;
+ return callmg;
+ }
+ return NULL;
+}
+
+/*
=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>.
@@ -10427,6 +10570,16 @@ 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>.
+See L</cv_set_call_checker_sv> for an alternative version which uses
+I<Perl_call_checker_sv> instead of I<Perl_call_checker>. If
+L</cv_set_call_checker_sv> is used to set the call checker,
+L</cv_get_call_checker_sv> must be used to retrieve it. Likewise,
+if L</cv_set_call_checker> is used to set the call checker,
+L</cv_get_call_checker> must be used to retrieve it. The sole
+exception to this rule is the default call checker; if the call checker
+is never set, or is set back to the default, each get call checker
+functions will return the appropriate version.
+
=cut
*/
@@ -10434,25 +10587,26 @@ 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;
- }
- callmg->mg_flags |= MGf_COPY;
- }
+ cv_set_call_checker_core(cv, (void *)ckfun, ckobj);
+}
+
+/*
+=for apidoc Am|void|cv_set_call_checker_sv|CV *cv|Perl_call_checker_sv *ckfun_p|SV **ckobj_p
+
+See L</cv_set_call_checker> for more details. The difference between the two versions is
+limited to the I<Perl_call_checker_sv> function taking a SV * instead of a GV * for the name
+of the function, since not all functions will have a GV.
+
+=cut
+*/
+
+void
+Perl_cv_set_call_checker_sv(pTHX_ CV *cv, Perl_call_checker_sv ckfun, SV *ckobj)
+{
+ PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_SV;
+ MAGIC * callmg = cv_set_call_checker_core(cv, (void *)ckfun, ckobj);
+ if (callmg)
+ callmg->mg_private = 1;
}
OP *
@@ -10461,6 +10615,7 @@ Perl_ck_subr(pTHX_ OP *o)
OP *aop, *cvop;
CV *cv;
GV *namegv;
+ SV *namesv;
PERL_ARGS_ASSERT_CK_SUBR;
@@ -10469,8 +10624,14 @@ Perl_ck_subr(pTHX_ OP *o)
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;
+ if (cvop->op_type == OP_PADCV && !(cvop->op_private & OPpENTERSUB_AMPER)) {
+ cv = padcv_op_cv(cvop, &namesv);
+ namegv = NULL;
+ } else {
+ cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
+ namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
+ namesv = namegv ? gv_ename(namegv) : sv_2mortal(newSVpvs("__ANON__::__ANON__"));
+ }
o->op_private &= ~1;
o->op_private |= OPpENTERSUB_HASTARG;
@@ -10496,20 +10657,25 @@ Perl_ck_subr(pTHX_ OP *o)
Perl_call_checker ckfun;
SV *ckobj;
cv_get_call_checker(cv, &ckfun, &ckobj);
- if (!namegv) { /* expletive! */
- /* XXX The call checker API is public. And it guarantees that
- a GV will be provided with the right name. So we have
- to create a GV. But it is still not correct, as its
- stringification will include the package. What we
- really need is a new call checker API that accepts a
- GV or string (or GV or CV). */
- HEK * const hek = CvNAME_HEK(cv);
- assert(hek);
- namegv = (GV *)sv_newmortal();
- gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
- SVf_UTF8 * !!HEK_UTF8(hek));
- }
- return ckfun(aTHX_ o, namegv, ckobj);
+ /* If a GV* call checker is in place, use it, otherwise use the SV* style */
+ if (ckfun != Perl_ck_entersub_args_proto_or_list) {
+ if (!namegv) { /* expletive! */
+ /* XXX The call checker API is public. And it guarantees that
+ a GV will be provided with the right name. So we have
+ to create a GV. But it is still not correct, as its
+ stringification will include the package. */
+ HEK * const hek = CvNAME_HEK(cv);
+ assert(hek);
+ namegv = (GV *)sv_newmortal();
+ gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
+ SVf_UTF8 * !!HEK_UTF8(hek));
+ }
+ return ckfun(aTHX_ o, namegv, ckobj);
+ } else {
+ Perl_call_checker_sv ckfun;
+ cv_get_call_checker_sv(cv, &ckfun, &ckobj);
+ return ckfun(aTHX_ o, namesv, ckobj);
+ }
}
}
diff --git a/proto.h b/proto.h
index 18f46cc..a323100 100644
--- a/proto.h
+++ b/proto.h
@@ -418,6 +418,20 @@ PERL_CALLCONV OP* Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, GV *
#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST \
assert(entersubop); assert(namegv); assert(protosv)
+PERL_CALLCONV OP* Perl_ck_entersub_args_proto_or_list_sv(pTHX_ OP *entersubop, SV *namesv, SV *protosv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST_SV \
+ assert(entersubop); assert(namesv); assert(protosv)
+
+PERL_CALLCONV OP* Perl_ck_entersub_args_proto_sv(pTHX_ OP *entersubop, SV *namesv, SV *protosv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_SV \
+ assert(entersubop); assert(namesv); assert(protosv)
+
PERL_CALLCONV OP * Perl_ck_eof(pTHX_ OP *o)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -758,6 +772,13 @@ PERL_CALLCONV void Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckf
#define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER \
assert(cv); assert(ckfun_p); assert(ckobj_p)
+PERL_CALLCONV void Perl_cv_get_call_checker_sv(pTHX_ CV *cv, Perl_call_checker_sv *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_SV \
+ 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)
@@ -765,6 +786,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_sv(pTHX_ CV *cv, Perl_call_checker_sv ckfun, SV *ckobj)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_SV \
+ 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 \
@@ -5863,11 +5891,25 @@ STATIC void S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, con
#define PERL_ARGS_ASSERT_BAD_TYPE_SV \
assert(t); assert(namesv); assert(kid)
+STATIC OP* S_ck_entersub_args_proto_core(pTHX_ OP *entersubop, void *namev, SV *protosv, bool name_is_gv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_CORE \
+ assert(entersubop); assert(namev); assert(protosv)
+
STATIC void S_cop_free(pTHX_ COP *cop)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_COP_FREE \
assert(cop)
+STATIC MAGIC* S_cv_set_call_checker_core(pTHX_ CV *cv, void *ckfun, SV *ckobj)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_CORE \
+ assert(cv); assert(ckfun); assert(ckobj)
+
STATIC OP * S_dup_attrlist(pTHX_ OP *o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_DUP_ATTRLIST \
@@ -5962,6 +6004,11 @@ PERL_STATIC_INLINE OP* S_op_std_init(pTHX_ OP *o)
#define PERL_ARGS_ASSERT_OP_STD_INIT \
assert(o)
+STATIC CV* S_padcv_op_cv(pTHX_ OP *padcvop, SV ** namesv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PADCV_OP_CV \
+ assert(padcvop)
+
STATIC OP* S_pmtrans(pTHX_ OP* o, OP* expr, OP* repl)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
diff --git a/t/cmd/lexsub.t b/t/cmd/lexsub.t
index 86c7e26..5f715fd 100644
--- a/t/cmd/lexsub.t
+++ b/t/cmd/lexsub.t
@@ -8,7 +8,7 @@ BEGIN {
*bar::like = *like;
}
no warnings 'deprecated';
-plan 128;
+plan 129;
# -------------------- Errors with feature disabled -------------------- #
@@ -86,6 +86,8 @@ sub bar::c { 43 }
{
our sub e ($);
is prototype "::e", '$', 'our sub with proto';
+ eval "e(1,2);";
+ like $@, qq 'Too many arguments for main::e at', 'prototypes honored with parens';
}
{
our sub if() { 42 }
@@ -415,12 +417,12 @@ sub mc { 43 }
}
package main;
{
- my sub me ($);
+ sub me ($);
is prototype eval{\&me}, '$', 'my sub with proto';
- is prototype "me", undef, 'prototype "..." ignores my subs';
+ is prototype "me", '$', 'prototype "..." ignores my subs';
}
{
- my sub if() { 44 }
+ my sub if { 44 }
my $x = if if if;
is $x, 44, 'my subs override all keywords';
package bar; |
From @cpansproutOn Fri Sep 12 00:26:55 2014, sprout wrote:
It is now in blead as merge commit f9d9e96. The new call checker API is in commit aa38f4b, and cv_name was added in c5569a5, fb09404 and b5e03f4. -- Father Chrysostomos |
|
@cpansprout - Status changed from 'open' to 'resolved' |
From @bulk88On Mon Sep 15 08:31:16 2014, sprout wrote:
Bug needs to be reopened. Visual C 2003 is complaining of new warnings because of these commits. cl -c -nologo -GF -W3 -I..\lib\CORE -I.\include -I. -I.. -DWIN32 -D_CONSOLE -DNO_STRICT -DPERLDLL -DPERL_CORE -O1 -MD -Zi -DNDEBUG -G7 -GL -DPERL_EXTERNAL_GLOB -DPERL_IS_MINIPERL -Fo.\mini\op.obj ..\op.c line 7897 7958 comes from Sept 15 2014 commit http://perl5.git.perl.org/perl.git/commit/2eaf799e74b14dc77b90d5484a3fd4ceac12b46a line 10751 comes from Sept 15 2014 commit line 10825 comes from Sept 15 2014 commit -- |
From @cpansproutOn Mon Sep 15 17:43:35 2014, bulk88 wrote:
Thank you.
Oops.
Oops.
Dumb compiler, but whatever. I have fixed, or at least hope I have fixed, these in 53d0634. -- Father Chrysostomos |
p5pRT commentedFeb 13, 2013
Migrated from rt.perl.org#116735 (status was 'resolved')
Searchable as RT116735$
The text was updated successfully, but these errors were encountered: