In perl.git, the branch blead has been updated

<https://perl5.git.perl.org/perl.git/commitdiff/910a6a8be166fb3780dcd2520e3526e537383ef2?hp=2b1f9c7143e15e2b934249f7fadadf156e31d40e>

- Log -----------------------------------------------------------------
commit 910a6a8be166fb3780dcd2520e3526e537383ef2
Author: Yves Orton <demer...@gmail.com>
Date:   Fri Feb 23 04:13:49 2018 +0100

    perl #132892: avoid leak by mortalizing temporary copy of pattern

commit c99363aa273278adcad39f32026629b700f9bbc3
Author: Yves Orton <demer...@gmail.com>
Date:   Sun Feb 18 07:29:03 2018 +0100

    fix Perl #132828 - dont use overload to bypass overloads
    
    the internals don't need overload.pm to be loaded to enable overloads
    which means that Carp needs to defend against overload without checking
    if overload.pm is loaded either.
    
    One odd thing about this change is that if I remove the "eval" that
    wraps the "require" then we fail tests in dist/Carp/t/vivify_stash.t
    which defies expectation as the require is never actually executed
    from that code.
    
    This patch doesn't have tests yet as it can segfault perl.

commit 4764858cb80e76fdba33cc1b3be8fcdef26df754
Author: Pali <p...@cpan.org>
Date:   Wed Jan 31 22:43:46 2018 +0100

    Fix RT #52610: Carp: Do not crash when reading @DB::args
    
    Trying to read values from array @DB::args can lead to perl fatal error
    "Bizarre copy of ARRAY in scalar assignment". But missing, incomplete or
    possible incorrect value in @DB::args is not a fatal error for Carp.
    
    Carp is primary used for reporting warnings and errors from other
    modules, so it should not crash perl when trying to print error message.
    
    This patch safely iterates all elements of @DB::args array via eval { }
    block and replace already freed scalars for Carp usage by string
    "** argument not available anymore **".
    
    This prevent crashing perl and allows to use Carp module. It it not a
    proper fix but rather workaround for Carp module. At least it allows to
    safely use Carp.
    
    Patch amended by Yves Orton

-----------------------------------------------------------------------

Summary of changes:
 MANIFEST                    |  1 +
 dist/Carp/lib/Carp.pm       | 44 ++++++++++++++++++++++++++++++++++----------
 dist/Carp/lib/Carp/Heavy.pm |  2 +-
 dist/Carp/t/rt52610_crash.t | 25 +++++++++++++++++++++++++
 dist/Carp/t/vivify_stash.t  | 12 ++++++------
 regcomp.c                   |  4 ++--
 6 files changed, 69 insertions(+), 19 deletions(-)
 create mode 100644 dist/Carp/t/rt52610_crash.t

diff --git a/MANIFEST b/MANIFEST
index bee41cc998..862b2aefdb 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2971,6 +2971,7 @@ dist/Carp/t/Carp_overload.t               See if Carp 
handles overloads
 dist/Carp/t/errno.t            See if Carp preserves $! and $^E
 dist/Carp/t/heavy.t            See if Carp::Heavy works
 dist/Carp/t/heavy_mismatch.t           See if Carp::Heavy catches version 
mismatch
+dist/Carp/t/rt52610_crash.t            Test that we can gracefully handle 
serializing the stack with stack-refcounting bugs
 dist/Carp/t/stash_deletion.t           See if Carp handles stash deletion
 dist/Carp/t/swash.t            See if Carp avoids breaking swash loading
 dist/Carp/t/vivify_gv.t                See if Carp leaves utf8:: stuff alone
diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
index eb7ad7bb06..8f93af11ac 100644
--- a/dist/Carp/lib/Carp.pm
+++ b/dist/Carp/lib/Carp.pm
@@ -116,7 +116,7 @@ BEGIN {
        ;
 }
 
-our $VERSION = '1.46';
+our $VERSION = '1.47_02';
 $VERSION =~ tr/_//d;
 
 our $MaxEvalLen = 0;
@@ -232,11 +232,22 @@ sub caller_info {
 
     my $sub_name = Carp::get_subname( \%call_info );
     if ( $call_info{has_args} ) {
-        my @args;
-        if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
-            && ref $DB::args[0] eq ref \$i
-            && $DB::args[0] == \$i ) {
-            @DB::args = ();    # Don't let anyone see the address of $i
+        # guard our serialization of the stack from stack refcounting bugs
+        my @args = map {
+                my $arg;
+                local $@= $@;
+                eval {
+                    $arg = $_;
+                    1;
+                } or do {
+                    $arg = '** argument not available anymore **';
+                };
+                $arg;
+            } @DB::args;
+        if (CALLER_OVERRIDE_CHECK_OK && @args == 1
+            && ref $args[0] eq ref \$i
+            && $args[0] == \$i ) {
+            @args = ();    # Don't let anyone see the address of $i
             local $@;
             my $where = eval {
                 my $func    = $cgc or return '';
@@ -255,7 +266,6 @@ sub caller_info {
                 = "** Incomplete caller override detected$where; \@DB::args 
were not set **";
         }
         else {
-            @args = @DB::args;
             my $overflow;
             if ( $MaxArgNums and @args > $MaxArgNums )
             {    # More than we want to show?
@@ -296,7 +306,7 @@ our $in_recurse;
 sub format_arg {
     my $arg = shift;
 
-    if ( ref($arg) ) {
+    if ( my $pack= ref($arg) ) {
 
         # lazy check if the CPAN module UNIVERSAL::isa is used or not
         #   if we use a rogue version of UNIVERSAL this would lead to infinite 
loop
@@ -326,8 +336,22 @@ sub format_arg {
         }
         else
         {
-           my $sub = _fetch_sub(overload => 'StrVal');
-           return $sub ? &$sub($arg) : "$arg";
+            # this particular bit of magic looking code is responsible for 
disabling overloads
+            # while we are stringifing arguments, otherwise if an overload 
calls a Carp sub we
+            # could end up in infinite recursion, which means we will exhaust 
the C stack and
+            # then segfault. Calling Carp obviously should not trigger an 
untrappable exception
+            # from Carp itself! - Yves
+            if ($pack->can("((")) {
+                # this eval is required, or fail the overload test
+                # in dist/Carp/t/vivify_stash.t, which is really quite weird.
+                # Even if we never enter this block, the presence of the 
require
+                # causes the test to fail. This seems like it might be a bug
+                # in require. Needs further investigation - Yves
+                eval "require overload; 1"
+                    or return "use overload failed";
+            }
+            my $sub = _fetch_sub(overload => 'StrVal');
+            return $sub ? &$sub($arg) : "$arg";
         }
     }
     return "undef" if !defined($arg);
diff --git a/dist/Carp/lib/Carp/Heavy.pm b/dist/Carp/lib/Carp/Heavy.pm
index 1d4bab613f..75ca4c5225 100644
--- a/dist/Carp/lib/Carp/Heavy.pm
+++ b/dist/Carp/lib/Carp/Heavy.pm
@@ -2,7 +2,7 @@ package Carp::Heavy;
 
 use Carp ();
 
-our $VERSION = '1.46';
+our $VERSION = '1.47_02';
 $VERSION =~ tr/_//d;
 
 # Carp::Heavy was merged into Carp in version 1.12.  Any mismatched versions
diff --git a/dist/Carp/t/rt52610_crash.t b/dist/Carp/t/rt52610_crash.t
new file mode 100644
index 0000000000..faa19cb890
--- /dev/null
+++ b/dist/Carp/t/rt52610_crash.t
@@ -0,0 +1,25 @@
+use warnings;
+use strict;
+
+use Test::More tests => 1;
+
+use Carp ();
+
+sub do_carp {
+    Carp::longmess;
+}
+
+sub call_with_args {
+    my ($arg_hash, $func) = @_;
+    $func->(@{$arg_hash->{'args'}});
+}
+
+my $msg;
+my $h = {};
+my $arg_hash = {'args' => [undef]};
+call_with_args($arg_hash, sub {
+    $arg_hash->{'args'} = [];
+    $msg = do_carp(sub { $h; });
+});
+
+like $msg, qr/^ at.+\b(?i:rt52610_crash\.t) line \d+\.\n\tmain::__ANON__\(.*\) 
called at.+\b(?i:rt52610_crash\.t) line 
\d+\n\tmain::call_with_args\(HASH\(0x[[:xdigit:]]+\), CODE\(0x[[:xdigit:]]+\)\) 
called at.+\b(?i:rt52610_crash\.t) line \d+$/;
diff --git a/dist/Carp/t/vivify_stash.t b/dist/Carp/t/vivify_stash.t
index 455aded7c1..46e0b637e9 100644
--- a/dist/Carp/t/vivify_stash.t
+++ b/dist/Carp/t/vivify_stash.t
@@ -8,20 +8,20 @@ our $has_UNIVERSAL_isa; BEGIN { $has_UNIVERSAL_isa = 
exists($UNIVERSAL::{"isa::"
 use Carp;
 sub { sub { Carp::longmess("x") }->() }->(\1, "\x{2603}", qr/\x{2603}/);
 
-print !(exists($::{"utf8::"}) xor $has_utf8) ? "" : "not ", "ok 1\n";
-print !(exists($::{"overload::"}) xor $has_overload) ? "" : "not ", "ok 2\n";
-print !(exists($::{"B::"}) xor $has_B) ? "" : "not ", "ok 3\n";
-print !(exists($UNIVERSAL::{"isa::"}) xor $has_UNIVERSAL_isa) ? "" : "not ", 
"ok 4\n";
+print !(exists($::{"utf8::"}) xor $has_utf8) ? "" : "not ", "ok 1 # used 
utf8\n";
+print !(exists($::{"overload::"}) xor $has_overload) ? "" : "not ", "ok 2 # 
used overload\n";
+print !(exists($::{"B::"}) xor $has_B) ? "" : "not ", "ok 3 # used B\n";
+print !(exists($UNIVERSAL::{"isa::"}) xor $has_UNIVERSAL_isa) ? "" : "not ", 
"ok 4 # used UNIVERSAL::isa\n";
 
 # Autovivify $::{"overload::"}
 () = \$::{"overload::"};
 () = \$::{"utf8::"};
 eval { sub { Carp::longmess() }->(\1) };
-print $@ eq '' ? "ok 5\n" : "not ok 5\n# $@";
+print $@ eq '' ? "ok 5 # longmess check1\n" : "not ok 5 # longmess check1\n# 
$@";
 
 # overload:: glob without hash
 undef *{"overload::"};
 eval { sub { Carp::longmess() }->(\1) };
-print $@ eq '' ? "ok 6\n" : "not ok 6\n# $@";
+print $@ eq '' ? "ok 6 # longmess check2\n" : "not ok 6 # longmess check2\n# 
$@";
 
 1;
diff --git a/regcomp.c b/regcomp.c
index 34ac9169f2..446f0bf839 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -6515,8 +6515,8 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
                     pat = msv;
                 } else {
                     /* a string with no trailing null, we need to copy it
-                     * so it we have a trailing null */
-                    pat = newSVsv(msv);
+                     * so it has a trailing null */
+                    pat = sv_2mortal(newSVsv(msv));
                 }
             }
 

-- 
Perl5 Master Repository

Reply via email to