Reapply squashed "avoid identical stack traces" patches

This reapplies two reverted patches as a single squashed commit.

Revert "Revert "avoid identical stack traces""
This reverts commit 79f75ea
which itself reverted f2f32cd

Revert "Revert "fixup to "avoid identical stack traces" - try 2""
This reverts commit 2abf7ef
which itself reverted ad89278

Original Author: David Mitchell <[email protected]>
Original Date:   Fri Dec 13 13:48:25 2019 +0000

avoid identical stack traces

GH #15109

The output of caller() (e.g. as produced by carp::Confess) produces
multiple identical outputs when within a nested use/require. This is
because at the time of calling the 'BEGIN { require ... }', PL_curcop is
set to &PL_compiling, which is a fixed buffer within the interpreter,
whose individual file and line fields are saved and restored when doing
a new require/eval. This means that within the innermost require,
PL_compiling has file:lineno of the innermost source file, and multiple
saved PL_curcop values in the context stack frames all point to the same
&PL_copmpiling.  So all levels of the stack trace appear to come from the
innermost file.

This commit fixes this (after a fashion) by, at the start of calling a
BEGIN, making PL_curcop point to a temporary copy of PL_compiling
instead.

This is all a bit of a hack.

Author: demerphq

MANIFEST

@@ -5682,6 +5682,10 @@ t/lib/feature/nonesuch		Tests for enabling/disabling nonexistent feature
 t/lib/feature/removed		Tests for enabling/disabling removed feature
 t/lib/feature/say		Tests for enabling/disabling say feature
 t/lib/feature/switch		Tests for enabling/disabling switch feature
+t/lib/GH_15109/Apack.pm		test Module for caller.t
+t/lib/GH_15109/Bpack.pm		test Module for caller.t
+t/lib/GH_15109/Cpack.pm		test Module for caller.t
+t/lib/GH_15109/Foo.pm		test Module for caller.t
 t/lib/h2ph.h			Test header file for h2ph
 t/lib/h2ph.pht			Generated output from h2ph.h by h2ph, for comparison
 t/lib/locale/latin1		Part of locale.t in Latin 1

op.c

@@ -12043,10 +12043,31 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
             (void)CvGV(cv);
             if (floor) LEAVE_SCOPE(floor);
             ENTER;
+
+            SAVEVPTR(PL_curcop);
+            if (PL_curcop == &PL_compiling) {
+                /* Avoid pushing the "global" &PL_compiling onto the
+                 * context stack. For example, a stack trace inside
+                 * nested use's would show all calls coming from whoever
+                 * most recently updated PL_compiling.cop_file and
+                 * cop_line.  So instead, temporarily set PL_curcop to a
+                 * private copy of &PL_compiling. PL_curcop will soon be
+                 * set to point back to &PL_compiling anyway but only
+                 * after the temp value has been pushed onto the context
+                 * stack as blk_oldcop.
+                 * This is slightly hacky, but necessary. Note also
+                 * that in the brief window before PL_curcop is set back
+                 * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
+                 * will give the wrong answer.
+                 */
+                PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
+                CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
+                SAVEFREEOP(PL_curcop);
+            }
+
             PUSHSTACKi(PERLSI_REQUIRE);
             SAVECOPFILE(&PL_compiling);
             SAVECOPLINE(&PL_compiling);
-            SAVEVPTR(PL_curcop);
 
             DEBUG_x( dump_sub(gv) );
             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));

t/lib/GH_15109/Apack.pm

@@ -0,0 +1,4 @@
+# for use by caller.t for GH #15109
+package Apack;
+use Bpack;
+1;

t/lib/GH_15109/Bpack.pm

@@ -0,0 +1,4 @@
+# for use by caller.t for GH #15109
+package Bpack;
+use Cpack;
+1;

t/lib/GH_15109/Cpack.pm

@@ -0,0 +1,11 @@
+# for use by caller.t for GH #15109
+package Cpack;
+
+
+my $i = 0;
+
+while (my ($package, $file, $line) = caller($i++)) {
+    push @Cpack::callers, "$file:$line";
+}
+
+1;

t/lib/GH_15109/Foo.pm

@@ -0,0 +1,9 @@
+# for use by caller.t for GH #15109
+
+package Foo;
+
+sub import {
+    use warnings; # restore default warnings
+    () = caller(1); # this used to cause valgrind errors
+}
+1;

t/op/caller.t

@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     require './test.pl';
     set_up_inc('../lib');
-    plan( tests => 97 ); # some tests are run in a BEGIN block
+    plan( tests => 111 ); # some tests are run in a BEGIN block
 }
 
 my @c;
@@ -335,16 +335,44 @@ $::testing_caller = 1;
 
 do './op/caller.pl' or die $@;
 
+# GH #15109
+# See that callers within a nested series of 'use's gets the right
+# filenames.
+{
+    local @INC = 'lib/GH_15109/';
+    # Apack use's Bpack which use's Cpack which populates @Cpack::caller
+    # with the file:N of all the callers
+    eval 'use Apack; 1';
+    is($@, "", "GH #15109 - eval");
+    is (scalar(@Cpack::callers), 10, "GH #15109 - callers count");
+    like($Cpack::callers[$_], qr{GH_15109/Bpack.pm:3}, "GH #15109 level $_") for 0..2;
+    like($Cpack::callers[$_], qr{GH_15109/Apack.pm:3}, "GH #15109 level $_") for 3..5;
+    like($Cpack::callers[$_], qr{\(eval \d+\):1}, "GH #15109 level $_") for 6..8;
+    like($Cpack::callers[$_], qr{caller\.t}, "GH #15109 level $_") for 9;
+
+    # GH #15109 followup - the original fix wasn't saving cop_warnings
+    # correctly and this code used to crash or fail valgrind
+
+    my $w = 0;
+    local $SIG{__WARN__} = sub { $w++ };
+    eval q{
+        use warnings;
+        no warnings 'numeric'; # ensure custom cop_warnings
+        use Foo;      # this used to mess up warnings flags
+        BEGIN { my $x = "foo" + 1; } # potential "numeric" warning
+    };
+    is ($@, "", "GH #15109 - eval okay");
+    is ($w, 0, "GH #15109 - warnings restored");
+}
+
 {
     package RT129239;
     BEGIN {
         my ($pkg, $file, $line) = caller;
         ::is $file, 'virtually/op/caller.t', "BEGIN block sees correct caller filename";
         ::is $line, 12345,                   "BEGIN block sees correct caller line";
-        TODO: {
-            local $::TODO = "BEGIN blocks have wrong caller package [perl #129239]";
-            ::is $pkg, 'RT129239',               "BEGIN block sees correct caller package";
-        }
+        ::is $pkg, 'RT129239',               "BEGIN block sees correct caller package";
 #line 12345 "virtually/op/caller.t"
     }
+
 }