Join GitHub today
GitHub is home to over 50 million developers working together to host and review code, manage projects, and build software together.
Sign uplexical 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 |
Migrated from rt.perl.org#116735 (status was 'resolved')
Searchable as RT116735$