This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
cv_name
authorFather Chrysostomos <sprout@cpan.org>
Thu, 28 Aug 2014 22:56:30 +0000 (15:56 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 15 Sep 2014 13:19:31 +0000 (06:19 -0700)
An API function for getting the name of a CV.  Docs to follow.

embed.fnc
embed.h
pad.c
proto.h

index 88adce2..8373e36 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -316,6 +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    |void   |cv_undef       |NN CV* cv
 p      |void   |cv_forget_slab |NN CV *cv
 Ap     |void   |cx_dump        |NN PERL_CONTEXT* cx
diff --git a/embed.h b/embed.h
index 17d1fd5..8293d49 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_set_call_checker(a,b,c)     Perl_cv_set_call_checker(aTHX_ a,b,c)
 #define cv_undef(a)            Perl_cv_undef(aTHX_ a)
 #define cx_dump(a)             Perl_cx_dump(aTHX_ a)
diff --git a/pad.c b/pad.c
index 38b0ce5..35c96d4 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -2228,6 +2228,38 @@ Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
     return S_cv_clone(aTHX_ proto, target, NULL);
 }
 
+SV *
+Perl_cv_name(pTHX_ CV *cv, SV *sv)
+{
+    PERL_ARGS_ASSERT_CV_NAME;
+    if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
+       if (sv) sv_setsv(sv,(SV *)cv);
+       return sv ? (sv) : (SV *)cv;
+    }
+    {
+       SV * const retsv = sv ? sv : sv_newmortal();
+       if (SvTYPE(cv) == SVt_PVCV) {
+           if (CvNAMED(cv)) {
+               if (CvLEXICAL(cv)) sv_sethek(retsv, CvNAME_HEK(cv));
+               else {
+                   sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
+                   sv_catpvs(retsv, "::");
+                   sv_catpvn_flags(retsv, HEK_KEY(CvNAME_HEK(cv)),
+                                   HEK_LEN(CvNAME_HEK(cv)),
+                                   HEK_UTF8(CvNAME_HEK(cv))
+                                       ? SV_CATUTF8
+                                       : SV_CATBYTES);
+               }
+           }
+           else if (CvLEXICAL(cv))
+               sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
+           else gv_efullname3(retsv, CvGV(cv), NULL);
+       }
+       else gv_efullname3(retsv,(GV *)cv,NULL);
+       return retsv;
+    }
+}
+
 /*
 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
 
diff --git a/proto.h b/proto.h
index 82496b6..3d8423d 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -811,6 +811,11 @@ 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)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_NAME       \
+       assert(cv)
+
 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)