Re: [PATCH] Re: Lack of error for large string on Solaris

Message-ID: <40C4A156.5030205@iki.fi>

p4raw-id: //depot/perl@22904

6 files changed, 156 insertions, 27 deletions

diff --git a/av.c b/av.c
index 9cae02393a..3eaeea8ecd 100644
--- a/av.c
+++ b/av.c
@@ -100,6 +100,11 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
 	    }
 	}
 	else {
+#ifdef PERL_MALLOC_WRAP
+	    static const char oom_array_extend[] =
+	      "Out of memory during array extend"; /* Duplicated in pp_hot.c */
+#endif
+
 	    if (AvALLOC(av)) {
 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
 		MEM_SIZE bytes;
@@ -114,7 +119,7 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
 #endif 
 		newmax = key + AvMAX(av) / 5;
 	      resize:
-		MEM_WRAP_CHECK_1(newmax+1, SV*, "panic: array extend");
+		MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 		Renew(AvALLOC(av),newmax+1, SV*);
 #else
@@ -149,7 +154,7 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
 	    }
 	    else {
 		newmax = key < 3 ? 3 : key;
-		MEM_WRAP_CHECK_1(newmax+1, SV*, "panic: array extend");
+		MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 		New(2,AvALLOC(av), newmax+1, SV*);
 		ary = AvALLOC(av) + 1;
 		tmp = newmax;
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 984a170bbb..e23036e183 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2643,6 +2643,11 @@ remaining memory (or virtual memory) to satisfy the request. However,
 the request was judged large enough (compile-time default is 64K), so a
 possibility to shut down by trapping this error is granted.
 
+=item Out of memory during %s extend
+
+(X) An attempt was made to extend an array, a list, or a string beyond
+the largest possible memory allocation.
+
 =item Out of memory during request for %s
 
 (X|F) The malloc() function returned 0, indicating there was
@@ -2694,11 +2699,6 @@ page.  See L<perlform>.
 
 (P) An internal error.
 
-=item panic: array extend
-
-(P) An attempt was made to extend an array beyond the largest possible
-memory allocation.
-
 =item panic: ck_grep
 
 (P) Failed an internal consistency check trying to compile a grep.
@@ -2775,11 +2775,6 @@ scope.
 (P) The savestack probably got out of sync.  At least, there was an
 invalid enum on the top of it.
 
-=item panic: list extend
-
-(P) An attempt was made to extend a list beyond the largest possible
-memory allocation.
-
 =item panic: magic_killbackrefs
 
 (P) Failed an internal consistency check while trying to reset all weak
@@ -2864,11 +2859,6 @@ then discovered it wasn't a subroutine or eval context.
 
 (P) scan_num() got called on something that wasn't a number.
 
-=item panic: string extend
-
-(P) An attempt was made to extend a string beyond the largest possible
-memory allocation.
-
 =item panic: sv_insert
 
 (P) The sv_insert() routine was told to remove more string than there
diff --git a/pp.c b/pp.c
index 2d73123117..001b9be795 100644
--- a/pp.c
+++ b/pp.c
@@ -1391,19 +1391,46 @@ PP(pp_repeat)
 {
   dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
   {
-    register IV count = POPi;
-    if (count < 0)
-	count = 0;
+    register IV count;
+    dPOPss;
+    if (SvGMAGICAL(sv))
+	 mg_get(sv);
+    if (SvIOKp(sv)) {
+	 if (SvUOK(sv)) {
+	      UV uv = SvUV(sv);
+	      if (uv > IV_MAX)
+		   count = IV_MAX; /* The best we can do? */
+	      else
+		   count = uv;
+	 } else {
+	      IV iv = SvIV(sv);
+	      if (iv < 0)
+		   count = 0;
+	      else
+		   count = iv;
+	 }
+    }
+    else if (SvNOKp(sv)) {
+	 NV nv = SvNV(sv);
+	 if (nv < 0.0)
+	      count = 0;
+	 else
+	      count = (IV)nv;
+    }
+    else
+	 count = SvIVx(sv);
     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
 	dMARK;
 	I32 items = SP - MARK;
 	I32 max;
-	static const char list_extend[] = "panic: list extend";
+	static const char oom_list_extend[] =
+	  "Out of memory during list extend";
 
 	max = items * count;
-	MEM_WRAP_CHECK_1(max, SV*, list_extend);
+	MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
+	/* Did the max computation overflow? */
 	if (items > 0 && max > 0 && (max < items || max < count))
-	   Perl_croak(aTHX_ list_extend);
+	   Perl_croak(aTHX_ oom_list_extend);
 	MEXTEND(MARK, max);
 	if (count > 1) {
 	    while (SP > MARK) {
@@ -1448,6 +1475,8 @@ PP(pp_repeat)
 	SV *tmpstr = POPs;
 	STRLEN len;
 	bool isutf;
+	static const char oom_string_extend[] =
+	  "Out of memory during string extend";
 
 	SvSetSV(TARG, tmpstr);
 	SvPV_force(TARG, len);
@@ -1456,7 +1485,10 @@ PP(pp_repeat)
 	    if (count < 1)
 		SvCUR_set(TARG, 0);
 	    else {
-	        MEM_WRAP_CHECK_1(count, len, "panic: string extend");
+		IV max = count * len;
+		if (len > ((MEM_SIZE)~0)/count)
+		     Perl_croak(aTHX_ oom_string_extend);
+	        MEM_WRAP_CHECK_1(max, char, oom_string_extend);
 		SvGROW(TARG, (count * len) + 1);
 		repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
 		SvCUR(TARG) *= count;
diff --git a/pp_hot.c b/pp_hot.c
index c3ce802e3c..3a89b6f1c3 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2879,6 +2879,18 @@ PP(pp_aelem)
 	RETPUSHUNDEF;
     svp = av_fetch(av, elem, lval && !defer);
     if (lval) {
+#ifdef PERL_MALLOC_WRAP
+	 static const char oom_array_extend[] =
+	      "Out of memory during array extend"; /* Duplicated in av.c */
+	 if (SvUOK(elemsv)) {
+	      UV uv = SvUV(elemsv);
+	      elem = uv > IV_MAX ? IV_MAX : uv;
+	 }
+	 else if (SvNOK(elemsv))
+	      elem = (IV)SvNV(elemsv);
+	 if (elem > 0)
+	      MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
+#endif
 	if (!svp || *svp == &PL_sv_undef) {
 	    SV* lv;
 	    if (!defer)
diff --git a/t/op/array.t b/t/op/array.t
index 8f2f1a9510..d7c1ee9175 100755
--- a/t/op/array.t
+++ b/t/op/array.t
@@ -1,12 +1,13 @@
 #!./perl
 
-
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
 }
 
-print "1..73\n";
+print "1..84\n";
+
+use Config;
 
 #
 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
@@ -272,3 +273,48 @@ my $got = runperl (
 $got =~ s/\n/ /g;
 print "# $got\nnot " unless $got eq '';
 print "ok 73\n";
+
+# Test negative and funky indices.
+
+{
+    my @a = 0..4;
+    print $a[-1] == 4 ? "ok 74\n" : "not ok 74\n";
+    print $a[-2] == 3 ? "ok 75\n" : "not ok 75\n";
+    print $a[-5] == 0 ? "ok 76\n" : "not ok 76\n";
+    print defined $a[-6] ? "not ok 77\n" : "ok 77\n";
+
+    print $a[2.1]   == 2 ? "ok 78\n" : "not ok 78\n";
+    print $a[2.9]   == 2 ? "ok 79\n" : "not ok 79\n";
+    print $a[undef] == 0 ? "ok 80\n" : "not ok 80\n";
+    print $a["3rd"] == 3 ? "ok 81\n" : "not ok 81\n";
+}
+
+sub kindalike { # TODO: test.pl-ize the array.t.
+    my ($s, $r, $m, $n) = @_;
+    print $s =~ /$r/ ? "ok $n - $m\n" : "not ok $n - $m ($s)\n";
+}
+
+{
+    my @a;
+    eval '$a[-1] = 0';
+    kindalike($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0", 82);
+}
+
+# Test the "malloc wrappage" guard introduced in Perl 5.8.4.
+
+if ($Config{ptrsize} == 4) {
+    eval '$a[0x7fffffff]=0';
+    kindalike($@, qr/Out of memory during array extend/,   "array extend", 83);
+
+    eval '$a[0x80000000]=0';
+    kindalike($@, qr/Out of memory during array extend/,   "array extend", 84);
+} elsif ($Config{ptrsize} == 8) {
+    eval '$a[0x7fffffffffffffff]=0';
+    kindalike($@, qr/Out of memory during array extend/,   "array extend", 83);
+
+    eval '$a[0x8000000000000000]=0';
+    kindalike($@, qr/Out of memory during array extend/,   "array extend", 84);
+} else {
+    die "\$Config{ptrsize} == $Config{ptrsize}?";
+}
+
diff --git a/t/op/repeat.t b/t/op/repeat.t
index d1b9c944e0..f33022ed0a 100755
--- a/t/op/repeat.t
+++ b/t/op/repeat.t
@@ -6,15 +6,21 @@ BEGIN {
 }
 
 require './test.pl';
-plan(tests => 33);
+plan(tests => 45);
+
+use Config;
 
 # compile time
 
 is('-' x 5, '-----',    'compile time x');
+is('-' x 3.1, '---',    'compile time 3.1');
+is('-' x 3.9, '---',    'compile time 3.9');
 is('-' x 1, '-',        '  x 1');
 is('-' x 0, '',         '  x 0');
 is('-' x -1, '',        '  x -1');
 is('-' x undef, '',     '  x undef');
+is('-' x "foo", '',     '  x "foo"');
+is('-' x "3rd", '---',  '  x "3rd"');
 
 is('ab' x 3, 'ababab',  '  more than one char');
 
@@ -22,10 +28,14 @@ is('ab' x 3, 'ababab',  '  more than one char');
 
 $a = '-';
 is($a x 5, '-----',     'run time x');
+is($a x 3.1, '---',     '  x 3.1');
+is($a x 3.9, '---',     '  x 3.9');
 is($a x 1, '-',         '  x 1');
 is($a x 0, '',          '  x 0');
 is($a x -3, '',         '  x -3');
 is($a x undef, '',      '  x undef');
+is($a x "foo", '',      '  x "foo"');
+is($a x "3rd", '---',   '  x "3rd"');
 
 $a = 'ab';
 is($a x 3, 'ababab',    '  more than one char');
@@ -144,3 +154,37 @@ is(77, scalar ((1,7)x2),    'stack truncation');
     is($y, 'abcdabcd');
 }
 
+# Test the "malloc wrappage" guards introduced in Perl 5.8.4.
+
+# Note that the guards do not catch everything: for example
+# "0"x0x7f...f is fine because it will attempt to allocate
+# "only" 0x7f...f+1 bytes: no wrappage there.
+
+if ($Config{ptrsize} == 4) {
+    eval '@a=(0)x0x7fffffff';
+    like($@, qr/Out of memory during list extend/,   "list extend");
+
+    eval '@a=(0)x0x80000000';
+    like($@, qr/Out of memory during list extend/,   "list extend");
+
+    eval '$a="012"x0x7fffffff';
+    like($@, qr/Out of memory during string extend/, "string extend");
+
+    eval '$a="012"x0x80000000';
+    like($@, qr/Out of memory during string extend/, "string extend");
+} elsif ($Config{ptrsize} == 8) {
+    eval '@a=(0)x0x7fffffffffffffff';
+    like($@, qr/Out of memory during list extend/,   "list extend");
+
+    eval '@a=(0)x0x8000000000000000';
+    like($@, qr/Out of memory during list extend/,   "list extend");
+
+    eval '$a="012"x0x7fffffffffffffff';
+    like($@, qr/Out of memory during string extend/, "string extend");
+
+    eval '$a="012"x0x8000000000000000';
+    like($@, qr/Out of memory during string extend/, "string extend");
+} else {
+    die "\$Config{ptrsize} == $Config{ptrsize}?";
+}
+