This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
RT: #126309 die more gracefully on (1) x ~1
authorDavid Mitchell <davem@iabyn.com>
Tue, 20 Oct 2015 14:04:49 +0000 (15:04 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 28 Oct 2015 12:55:28 +0000 (12:55 +0000)
Recent improvements to MEXTEND() etc means that the above is now caught and
panics rather than crashing. However, the panic is:

    panic: av_extend_guts() negative count (-9223372036854775681)

which is safe, but not pretty. This commit makes it croak instead with:

    Out of memory during stack extend

Basically Perl_stack_grow() adds an extra 128 bytes of headroom to the
amount it actually extends the stack by. Check in stack_grow() itself
whether this has wrapped, rather than leaving it to av_extend_guts(),
which can only give a generic panic message.

scope.c
t/op/repeat.t

diff --git a/scope.c b/scope.c
index 1b89186..bdf299a 100644 (file)
--- a/scope.c
+++ b/scope.c
 SV**
 Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n)
 {
+    SSize_t extra;
+    SSize_t current = (p - PL_stack_base);
+
     PERL_ARGS_ASSERT_STACK_GROW;
 
-    if (n < 0)
+    if (UNLIKELY(n < 0))
         Perl_croak(aTHX_
             "panic: stack_grow() negative count (%"IVdf")", (IV)n);
 
     PL_stack_sp = sp;
-#ifndef STRESS_REALLOC
-    av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128);
+    extra =
+#ifdef STRESS_REALLOC
+        1;
 #else
-    av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1);
+        128;
 #endif
+    /* If the total might wrap, panic instead. This is really testing
+     * that (current + n + extra < SSize_t_MAX), but done in a way that
+     * can't wrap */
+    if (UNLIKELY(   current         > SSize_t_MAX - extra
+                 || current + extra > SSize_t_MAX - n
+    ))
+        /* diag_listed_as: Out of memory during %s extend */
+        Perl_croak(aTHX_ "Out of memory during stack extend");
+
+    av_extend(PL_curstack, current + n + extra);
     return PL_stack_sp;
 }
 
index 8df5241..bee7dac 100644 (file)
@@ -6,7 +6,7 @@ BEGIN {
 }
 
 require './test.pl';
-plan(tests => 47);
+plan(tests => 48);
 
 # compile time
 
@@ -173,3 +173,13 @@ for(($#that_array)x2) {
     $_ *= 2;
 }
 is($#that_array, 28, 'list repetition propagates lvalue cx to its lhs');
+
+# [perl #126309] huge list counts should give an error
+
+
+fresh_perl_like(
+ '@a = (1) x ~1',
+  qr/Out of memory/,
+  {  },
+ '(1) x ~1',
+);