In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3613e672611050280ed9ed15546538e2b16b9a45?hp=8ea199e3a0196f596ff77acbc8ccac85fa2da7dd>
- Log ----------------------------------------------------------------- commit 3613e672611050280ed9ed15546538e2b16b9a45 Author: Father Chrysostomos <[email protected]> Date: Wed Sep 24 00:40:23 2014 -0700 Increase $XS::APItest::VERSION to 0.65 M ext/XS-APItest/APItest.pm commit ecf05a582e3c4c0f74622847331af430479c4fcb Author: Father Chrysostomos <[email protected]> Date: Wed Sep 24 00:37:58 2014 -0700 Add flags to cv_name; allow unqualified retval One of the main purposes of cv_name was to provide a way for CPAN mod- ules easily to obtain the name of a sub. As written, it was not actually sufficient, as some modules, such as Devel::Declare, need an unqualified name. So I am breaking compatibility with 5.21.4 (which introduced cv_name, but is only a dev release) by adding a flags parameter. M dump.c M embed.fnc M embed.h M ext/XS-APItest/APItest.xs M ext/XS-APItest/t/cv_name.t M op.c M pad.c M pp_ctl.c M pp_hot.c M proto.h commit 5e8814954c268f117d70c5156096c5bf7bb1cff7 Author: Father Chrysostomos <[email protected]> Date: Wed Sep 24 00:22:29 2014 -0700 embed.fnc: cv_name is documented M cv.h M embed.fnc ----------------------------------------------------------------------- Summary of changes: cv.h | 2 ++ dump.c | 2 +- embed.fnc | 2 +- embed.h | 2 +- ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 6 +++++- ext/XS-APItest/t/cv_name.t | 26 +++++++++++++++++++++++++- op.c | 10 +++++----- pad.c | 12 +++++++++--- pp_ctl.c | 2 +- pp_hot.c | 4 ++-- proto.h | 2 +- 12 files changed, 54 insertions(+), 18 deletions(-) diff --git a/cv.h b/cv.h index 8ba1c5c..7f6dea2 100644 --- a/cv.h +++ b/cv.h @@ -270,6 +270,8 @@ typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *); #define CALL_CHECKER_REQUIRE_GV MGf_REQUIRE_GV +#define CV_NAME_NOTQUAL 1 + #ifdef PERL_CORE # define CV_UNDEF_KEEP_NAME 1 #endif diff --git a/dump.c b/dump.c index 8fc433c..420c486 100644 --- a/dump.c +++ b/dump.c @@ -2277,7 +2277,7 @@ Perl_debop(pTHX_ const OP *o) assert(SvROK(cGVOPo_gv)); assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV); PerlIO_printf(Perl_debug_log, "(cv ref: %s)", - SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv))); + SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0))); SvREFCNT_dec_NN(sv); } else diff --git a/embed.fnc b/embed.fnc index a8789ac..f9ba3f6 100644 --- a/embed.fnc +++ b/embed.fnc @@ -316,7 +316,7 @@ ApdRn |SV* |cv_const_sv |NULLOK const CV *const cv pRn |SV* |cv_const_sv_or_av|NULLOK const CV *const cv : Used in pad.c pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv -Ap |SV * |cv_name |NN CV *cv|NULLOK SV *sv +Apd |SV * |cv_name |NN CV *cv|NULLOK SV *sv|U32 flags Apd |void |cv_undef |NN CV* cv p |void |cv_undef_flags |NN CV* cv|U32 flags p |void |cv_forget_slab |NN CV *cv diff --git a/embed.h b/embed.h index cd5c1d2..253fde5 100644 --- a/embed.h +++ b/embed.h @@ -100,7 +100,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_name(a,b) Perl_cv_name(aTHX_ a,b) +#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) #define cv_undef(a) Perl_cv_undef(aTHX_ a) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 2950eaf..1dbb16f 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.64'; +our $VERSION = '0.65'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 777e342..1c4428a 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -3592,7 +3592,11 @@ alias_av(AV *av, IV ix, SV *sv) SV * cv_name(SVREF ref, ...) CODE: - RETVAL = SvREFCNT_inc(cv_name((CV *)ref, items>1 ? ST(1) : NULL)); + RETVAL = SvREFCNT_inc(cv_name((CV *)ref, + items>1 && ST(1) != &PL_sv_undef + ? ST(1) + : NULL, + items>2 ? SvUV(ST(2)) : 0)); OUTPUT: RETVAL diff --git a/ext/XS-APItest/t/cv_name.t b/ext/XS-APItest/t/cv_name.t index cc6202a..450336e 100644 --- a/ext/XS-APItest/t/cv_name.t +++ b/ext/XS-APItest/t/cv_name.t @@ -1,5 +1,5 @@ use XS::APItest; -use Test::More tests => 15; +use Test::More tests => 30; use feature "lexical_subs", "state"; no warnings "experimental::lexical_subs"; @@ -27,3 +27,27 @@ state sub lex2; $ret = \cv_name(\&lex2, $name); is $ret, \$name, 'cv_name with lexical sub returns 2nd argument'; is ($name, 'lex2', 'retval of cv_name with lexical sub & 2nd arg'); + +# nq in test names means CV_NAME_NOTQUAL +is (cv_name(\&foo, undef, 1), 'foo', 'cv_name with package sub (nq)'); +is (cv_name(*{"foo"}{CODE}, undef, 1), 'foo', + 'cv_name with package sub via glob (nq)'); +is (cv_name(\*{"foo"}, undef, 1), 'foo', 'cv_name with typeglob (nq)'); +is (cv_name(\"foo", undef, 1), 'foo', 'cv_name with string (nq)'); +is (cv_name(\&lex1, undef, 1), 'lex1', 'cv_name with lexical sub (nq)'); + +$ret = \cv_name(\&bar, $name, 1); +is $ret, \$name, 'cv_name with package sub returns 2nd argument (nq)'; +is ($name, 'bar', 'retval of cv_name with package sub & 2nd arg (nq)'); +$ret = \cv_name(*{"bar"}{CODE}, $name, 1); +is $ret, \$name, 'cv_name with package sub via glob returns 2nd arg (nq)'; +is ($name, 'bar', 'retval of cv_name w/pkg sub via glob & 2nd arg (nq)'); +$ret = \cv_name(\*{"bar"}, $name, 1); +is $ret, \$name, 'cv_name with typeglob returns 2nd argument (nq)'; +is ($name, 'bar', 'retval of cv_name with typeglob & 2nd arg (nq)'); +$ret = \cv_name(\"bar", $name, 1); +is $ret, \$name, 'cv_name with string returns 2nd argument (nq)'; +is ($name, 'bar', 'retval of cv_name with string & 2nd arg (nq)'); +$ret = \cv_name(\&lex2, $name, 1); +is $ret, \$name, 'cv_name with lexical sub returns 2nd argument (nq)'; +is ($name, 'lex2', 'retval of cv_name with lexical sub & 2nd arg (nq)'); diff --git a/op.c b/op.c index 42f73ed..7d1cca9 100644 --- a/op.c +++ b/op.c @@ -535,7 +535,7 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP STATIC void S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) { - SV * const namesv = cv_name((CV *)gv, NULL); + SV * const namesv = cv_name((CV *)gv, NULL, 0); PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", @@ -8027,7 +8027,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (block && has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = cv_name(cv,NULL); + SV * const tmpstr = cv_name(cv,NULL,0); GV * const db_postponed = gv_fetchpvs("DB::postponed", GV_ADDMULTI, SVt_PVHV); HV *hv; @@ -10417,7 +10417,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (proto >= proto_end) { - SV * const namesv = cv_name((CV *)namegv, NULL); + SV * const namesv = cv_name((CV *)namegv, NULL, 0); yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), SvUTF8(namesv)); return entersubop; @@ -10572,7 +10572,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) default: oops: { Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, - SVfARG(cv_name((CV *)namegv, NULL)), + SVfARG(cv_name((CV *)namegv, NULL, 0)), SVfARG(protosv)); } } @@ -10588,7 +10588,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) { - SV * const namesv = cv_name((CV *)namegv, NULL); + SV * const namesv = cv_name((CV *)namegv, NULL, 0); yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)), SvUTF8(namesv)); } diff --git a/pad.c b/pad.c index 1306a0a..cda443b 100644 --- a/pad.c +++ b/pad.c @@ -2247,11 +2247,15 @@ An SV may be passed as a second argument. If so, the name will be assigned to it and it will be returned. Otherwise the returned SV will be a new mortal. +If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be +included. If the first argument is neither a CV nor a GV, this flag is +ignored (subject to change). + =cut */ SV * -Perl_cv_name(pTHX_ CV *cv, SV *sv) +Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags) { PERL_ARGS_ASSERT_CV_NAME; if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) { @@ -2262,17 +2266,19 @@ Perl_cv_name(pTHX_ CV *cv, SV *sv) SV * const retsv = sv ? (sv) : sv_newmortal(); if (SvTYPE(cv) == SVt_PVCV) { if (CvNAMED(cv)) { - if (CvLEXICAL(cv)) sv_sethek(retsv, CvNAME_HEK(cv)); + if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) + sv_sethek(retsv, CvNAME_HEK(cv)); else { sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv))); sv_catpvs(retsv, "::"); sv_cathek(retsv, CvNAME_HEK(cv)); } } - else if (CvLEXICAL(cv)) + else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv)))); else gv_efullname3(retsv, CvGV(cv), NULL); } + else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv)); else gv_efullname3(retsv,(GV *)cv,NULL); return retsv; } diff --git a/pp_ctl.c b/pp_ctl.c index e716fc7..d72ec1c 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1820,7 +1820,7 @@ PP(pp_caller) if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { /* So is ccstack[dbcxix]. */ if (CvHASGV(dbcx->blk_sub.cv)) { - PUSHs(cv_name(dbcx->blk_sub.cv, 0)); + PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0)); PUSHs(boolSV(CxHASARGS(cx))); } else { diff --git a/pp_hot.c b/pp_hot.c index 4f9519d..63e0836 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2624,7 +2624,7 @@ PP(pp_entersub) /* anonymous or undef'd function leaves us no recourse */ if (CvLEXICAL(cv) && CvHASGV(cv)) DIE(aTHX_ "Undefined subroutine &%"SVf" called", - SVfARG(cv_name(cv, NULL))); + SVfARG(cv_name(cv, NULL, 0))); if (CvANON(cv) || !CvHASGV(cv)) { DIE(aTHX_ "Undefined subroutine called"); } @@ -2830,7 +2830,7 @@ Perl_sub_crush_depth(pTHX_ CV *cv) Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", - SVfARG(cv_name(cv,NULL))); + SVfARG(cv_name(cv,NULL,0))); } } diff --git a/proto.h b/proto.h index d6d3a86..144a9ce 100644 --- a/proto.h +++ b/proto.h @@ -811,7 +811,7 @@ 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 SV * Perl_cv_name(pTHX_ CV *cv, SV *sv) +PERL_CALLCONV SV * Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CV_NAME \ assert(cv) -- Perl5 Master Repository
