From: David Mitchell <davem@iabyn.com>
Date: Thu, 12 Mar 2020 14:14:24 +0000 (+0000)
Subject: fixup to "avoid identical stack traces" - try 2
X-Git-Tag: v5.31.10~34
X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/ad89278aa25475fb03971aec66692e18e35d9c07?hp=2f07b2fb1d76d4d4f344f296ee3432f3f3ce4580;ds=sidebyside

fixup to "avoid identical stack traces" - try 2

GH #15109, #17567

[ this commit was originally applied as v5.31.9-121-gfb8188b84d, but was
quickly reverted by v5.31.9-124-g6311900a66. I'm now -re-applying it,
but with a 'SAVEFREEOP(PL_curcop)' added, which was missing from the
original commit. ]

My original fix for this issue, v5.31.6-141-gf2f32cd638
made a shallow copy of &PL_compiling. However, for non-default
warning bits, this made two COPs share the malloced() cop_warnings,
and bad things ensured. In particular this was flagged up in:

    GH #17567: "BBC: AYOUNG/OpenVZ-0.01.tar.gz"

The fix in this commit is to do a deep copy of the COP using
newSTATEOP().
---

diff --git a/MANIFEST b/MANIFEST
index de09d6c..841bdf2 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5648,6 +5648,7 @@ 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
diff --git a/op.c b/op.c
index 954bb32..0b8e961 100644
--- a/op.c
+++ b/op.c
@@ -11712,10 +11712,9 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
                  * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
                  * will give the wrong answer.
                  */
-                Newx(PL_curcop, 1, COP);
-                StructCopy(&PL_compiling, PL_curcop, COP);
-                PL_curcop->op_slabbed = 0;
-                SAVEFREEPV(PL_curcop);
+                PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
+                CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
+                SAVEFREEOP(PL_curcop);
             }
 
             PUSHSTACKi(PERLSI_REQUIRE);
diff --git a/t/lib/GH_15109/Foo.pm b/t/lib/GH_15109/Foo.pm
new file mode 100644
index 0000000..1af2547
--- /dev/null
+++ b/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;
diff --git a/t/op/caller.t b/t/op/caller.t
index 9fc9a1c..865b005 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 => 109 ); # some tests are run in a BEGIN block
+    plan( tests => 111 ); # some tests are run in a BEGIN block
 }
 
 my @c;
@@ -349,6 +349,20 @@ do './op/caller.pl' or die $@;
     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");
 }
 
 {
@@ -357,11 +371,9 @@ do './op/caller.pl' or die $@;
         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"
     }
+
 }