From: Father Chrysostomos Date: Sun, 1 Sep 2013 00:47:23 +0000 (-0700) Subject: [perl #115768] improve (caller)[2] line numbers X-Git-Tag: upstream/5.20.0~2048 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=25502127feba592f2312380b350122c445020707;p=platform%2Fupstream%2Fperl.git [perl #115768] improve (caller)[2] line numbers warn and die have special code (closest_cop) to find a nulled nextstate op closest to the warn or die op, to get the line number from it. This commit extends that capability to caller, so that if (1) { foo(); } sub foo { warn +(caller)[2] } shows the right line number. --- diff --git a/embed.fnc b/embed.fnc index f18ecb4..088086e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -258,6 +258,8 @@ ApR |UV |cast_uv |NV f #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) ApR |I32 |my_chsize |int fd|Off_t length #endif +p |const COP*|closest_cop |NN const COP *cop|NULLOK const OP *o \ + |NULLOK const OP *curop|bool opnext : Used in perly.y pR |OP* |convert |I32 optype|I32 flags|NULLOK OP* o : Used in op.c and perl.c @@ -2285,7 +2287,6 @@ s |bool |is_cur_LC_category_utf8|int category #endif #if defined(PERL_IN_UTIL_C) -s |const COP*|closest_cop |NN const COP *cop|NULLOK const OP *o s |SV* |mess_alloc s |SV * |with_queued_errors|NN SV *ex s |bool |invoke_exception_hook|NULLOK SV *ex|bool warn diff --git a/embed.h b/embed.h index 5ce9ed0..7708a61 100644 --- a/embed.h +++ b/embed.h @@ -1067,6 +1067,7 @@ #define ck_svconst(a) Perl_ck_svconst(aTHX_ a) #define ck_tell(a) Perl_ck_tell(aTHX_ a) #define ck_trunc(a) Perl_ck_trunc(aTHX_ a) +#define closest_cop(a,b,c,d) Perl_closest_cop(aTHX_ a,b,c,d) #define convert(a,b,c) Perl_convert(aTHX_ a,b,c) #define core_prototype(a,b,c,d) Perl_core_prototype(aTHX_ a,b,c,d) #define coresub_op(a,b,c) Perl_coresub_op(aTHX_ a,b,c) @@ -1667,7 +1668,6 @@ # endif # if defined(PERL_IN_UTIL_C) #define ckwarn_common(a) S_ckwarn_common(aTHX_ a) -#define closest_cop(a,b) S_closest_cop(aTHX_ a,b) #define invoke_exception_hook(a,b) S_invoke_exception_hook(aTHX_ a,b) #define mess_alloc() S_mess_alloc(aTHX) #define with_queued_errors(a) S_with_queued_errors(aTHX_ a) diff --git a/pp_ctl.c b/pp_ctl.c index b9ef68f..4ce8ddb 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1811,6 +1811,7 @@ PP(pp_caller) const HEK *stash_hek; I32 count = 0; bool has_arg = MAXARG && TOPs; + const COP *lcop; if (MAXARG) { if (has_arg) @@ -1854,7 +1855,11 @@ PP(pp_caller) PUSHTARG; } mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); - mPUSHi((I32)CopLINE(cx->blk_oldcop)); + lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling, + cx->blk_sub.retop, TRUE); + if (!lcop) + lcop = cx->blk_oldcop; + mPUSHi((I32)CopLINE(lcop)); if (!has_arg) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { diff --git a/proto.h b/proto.h index a0329bb..a3106cb 100644 --- a/proto.h +++ b/proto.h @@ -663,6 +663,11 @@ PERL_CALLCONV void Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) PERL_CALLCONV bool Perl_ckwarn(pTHX_ U32 w); PERL_CALLCONV bool Perl_ckwarn_d(pTHX_ U32 w); +PERL_CALLCONV const COP* Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, bool opnext) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CLOSEST_COP \ + assert(cop) + PERL_CALLCONV OP* Perl_convert(pTHX_ I32 optype, I32 flags, OP* o) __attribute__warn_unused_result__; @@ -7519,11 +7524,6 @@ PERL_CALLCONV UV Perl__to_fold_latin1(pTHX_ const U8 c, U8 *p, STRLEN *lenp, con #endif #if defined(PERL_IN_UTIL_C) STATIC bool S_ckwarn_common(pTHX_ U32 w); -STATIC const COP* S_closest_cop(pTHX_ const COP *cop, const OP *o) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_CLOSEST_COP \ - assert(cop) - STATIC bool S_invoke_exception_hook(pTHX_ SV *ex, bool warn); STATIC SV* S_mess_alloc(pTHX); STATIC SV * S_with_queued_errors(pTHX_ SV *ex) diff --git a/t/op/caller.t b/t/op/caller.t index 09728d3..61a3816 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; - plan( tests => 92 ); + plan( tests => 94 ); } my @c; @@ -269,6 +269,19 @@ END is eval "(caller 0)[6]", "(caller 0)[6]", 'eval text returned by caller does not include \n;'; +if (1) { + is (sub { (caller)[2] }->(), __LINE__, + '[perl #115768] caller gets line numbers from nulled cops'); +} +# Test it at the end of the program, too. +fresh_perl_is(<<'115768', 2, {}, + if (1) { + foo(); + } + sub foo { print +(caller)[2] } +115768 + '[perl #115768] caller gets line numbers from nulled cops (2)'); + # PL_linestr should not be modifiable eval '"${;BEGIN{ ${\(caller 2)[6]} = *foo }}"'; pass "no assertion failure after modifying eval text via caller"; diff --git a/util.c b/util.c index 00f3821..0cd99f3 100644 --- a/util.c +++ b/util.c @@ -1178,15 +1178,20 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } -STATIC const COP* -S_closest_cop(pTHX_ const COP *cop, const OP *o) +const COP* +Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, + bool opnext) { dVAR; - /* Look for PL_op starting from o. cop is the last COP we've seen. */ + /* Look for curop starting from o. cop is the last COP we've seen. */ + /* opnext means that curop is actually the ->op_next of the op we are + seeking. */ PERL_ARGS_ASSERT_CLOSEST_COP; - if (!o || o == PL_op) + if (!o || !curop || ( + opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop + )) return cop; if (o->op_flags & OPf_KIDS) { @@ -1202,7 +1207,7 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o) /* Keep searching, and return when we've found something. */ - new_cop = closest_cop(cop, kid); + new_cop = closest_cop(cop, kid, curop, opnext); if (new_cop) return new_cop; } @@ -1272,7 +1277,8 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) * from the sibling of PL_curcop. */ - const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling); + const COP *cop = + closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE); if (!cop) cop = PL_curcop;