Commit 828aeb74b0 for perl

commit 828aeb74b0265eb5e028fcb625b54c565cdd2d2a
Author: Richard Leach <rich+perl@hyphen-dash-hyphen.info>
Date:   Wed Oct 21 15:13:42 2026 +0000

    Stash PL_op in block_sub stack frames so caller can disambiguate

    Prior to this commit, `caller()` was unable to correctly determine
    which of the following branches was responsible for calling the
    `bogocarp` subroutine. (Specifically, `caller` would decide that
    the `if` block was responsible for all three calls, but each of
    the branches is actually responsible for one each.)

        sub bogocarp { my ($fi, $pa, $line) = caller; warn $line; }
        sub t {
            if ($_[0] == 0) {
                bogocarp();
            } elsif ($_[0] == 1) {
                bogocarp();
            } else {
                bogocarp();
            }
        }
        t(0); t(1); t(2);

    With this commit:
    * An extra `OP *` is added to the `block_sub` struct.
    (Although its size increases, the size of the `blk_u` union that is
    pushed onto the context stack does not. `block_eval` was larger.)
    * `Perl_cx_pushsub` stores `PL_op` in that `OP *`.
    * `S_caller_push_line` uses that `OP *` when `CxTYPE(cx) == CXt_SUB`

diff --git a/cop.h b/cop.h
index dc36e8aa1e..8ad9ec4075 100644
--- a/cop.h
+++ b/cop.h
@@ -873,6 +873,7 @@ struct block_sub {
     /* Above here is the same for sub and format.  */
     I32		olddepth;
     AV  	*savearray;
+    OP          *callop; /* calling OP, for use by caller() */
 };


diff --git a/inline.h b/inline.h
index 43f290dc3f..de91b3f644 100644
--- a/inline.h
+++ b/inline.h
@@ -4143,6 +4143,7 @@ Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
     cx->blk_sub.prevcomppad = PL_comppad;
     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
     cx->blk_sub.retop = retop;
+    cx->blk_sub.callop = PL_op;
     SvREFCNT_inc_simple_void_NN(cv);
     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
 }
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index f53ce3c50e..cee4f0981a 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -368,6 +368,11 @@ manager will later use a regex to expand these into links.

 XXX

+=item *
+
+L<perlfunc/caller> is better able to identify the correct call site when
+multiple branches of an C<if>/C<elsif>/C<else> chain call the same function.
+
 =back

 =head1 Known Problems
diff --git a/pp_ctl.c b/pp_ctl.c
index bd8f778481..06fa2f3392 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2325,8 +2325,9 @@ static void
 S_caller_push_line(pTHX_ const PERL_CONTEXT *cx)
 {
     const COP *blk_old = cx->blk_oldcop;
-    const COP *lcop = closest_cop(blk_old, OpSIBLING(blk_old),
-                                           cx->blk_sub.retop, TRUE);
+    const COP *lcop = (CxTYPE(cx) == CXt_SUB)
+        ? closest_cop(blk_old, OpSIBLING(blk_old), cx->blk_sub.callop, FALSE)
+        : closest_cop(blk_old, OpSIBLING(blk_old), cx->blk_sub.retop, TRUE);
     if (!lcop)
         lcop = blk_old;
     rpp_push_1_norc( newSVuv( (UV)(CopLINE(lcop)) ) );
diff --git a/t/op/caller.t b/t/op/caller.t
index f1d3d4a6a0..6f5b71bd34 100644
--- a/t/op/caller.t
+++ b/t/op/caller.t
@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     require './test.pl';
     set_up_inc('../lib');
-    plan( tests => 126 ); # some tests are run in a BEGIN block
+    plan( tests => 127 ); # some tests are run in a BEGIN block
 }

 my @c;
@@ -479,3 +479,19 @@ END
     sub scalar_gives_filename { (caller 0)[0,1] }
     like scalar scalar_gives_filename(), qr![/\\]caller\.t$!, "Optimized caller lslice in runtime scalar context";
 }
+
+fresh_perl_is(<<'END', "4 at - line 1.\n6 at - line 1.\n8 at - line 1.", {},
+    sub bogocarp { my ($fi, $pa, $line) = caller; warn $line; }
+    sub t {
+        if ($_[0] == 0) {
+            bogocarp();
+        } elsif ($_[0] == 1) {
+            bogocarp();
+        } else {
+            bogocarp();
+        }
+    }
+    t(0); t(1); t(2);
+END
+    'caller differentiates between branches calling the same function');
+