summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--dump.c2
-rw-r--r--embed.fnc2
-rw-r--r--embed.h2
-rw-r--r--ext/XS-APItest/APItest.xs6
-rw-r--r--ext/XS-APItest/t/cv_name.t26
-rw-r--r--op.c10
-rw-r--r--pad.c12
-rw-r--r--pp_ctl.c2
-rw-r--r--pp_hot.c4
-rw-r--r--proto.h2
10 files changed, 51 insertions, 17 deletions
diff --git a/dump.c b/dump.c
index 8fc433c912..420c486cb2 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 ee8ca59dbc..f9ba3f626b 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
-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 cd5c1d2519..253fde5a5d 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.xs b/ext/XS-APItest/APItest.xs
index 777e342398..1c4428aabb 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 cc6202adf0..450336e26c 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 42f73ed809..7d1cca94ff 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 1306a0a1e4..cda443b897 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 e716fc7821..d72ec1c2f4 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 4f9519de67..63e0836f39 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 d6d3a8676a..144a9cec63 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)
View Lorry Controller Status