From: Jarkko Hietaniemi Date: Mon, 7 Jun 2004 20:09:42 +0000 (+0300) Subject: Re: [PATCH] Re: Lack of error for large string on Solaris X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2b573acec7886e18e5f2804e8915073100dce2e4;p=p5sagit%2Fp5-mst-13.2.git Re: [PATCH] Re: Lack of error for large string on Solaris Message-ID: <40C4A156.5030205@iki.fi> p4raw-id: //depot/perl@22904 --- diff --git a/av.c b/av.c index 9cae023..3eaeea8 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 984a170..e23036e 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. (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 2d73123..001b9be 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 c3ce802..3a89b6f 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 8f2f1a9..d7c1ee9 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 d1b9c94..f33022e 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}?"; +} +