This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add flags to cv_name; allow unqualified retval
authorFather Chrysostomos <sprout@cpan.org>
Wed, 24 Sep 2014 07:37:58 +0000 (00:37 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Wed, 24 Sep 2014 07:37:58 +0000 (00:37 -0700)
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.

dump.c
embed.fnc
embed.h
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/cv_name.t
op.c
pad.c
pp_ctl.c
pp_hot.c
proto.h

diff --git a/dump.c b/dump.c
index 8fc433c..420c486 100644 (file)
--- 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
index ee8ca59..f9ba3f6 100644 (file)
--- 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
-Apd    |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 (file)
--- a/embed.h
+++ b/embed.h
 #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)
index 777e342..1c4428a 100644 (file)
@@ -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
 
index cc6202a..450336e 100644 (file)
@@ -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 (file)
--- 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 (file)
--- 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;
     }
index e716fc7..d72ec1c 100644 (file)
--- 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 {
index 4f9519d..63e0836 100644 (file)
--- 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 (file)
--- 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)