[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;