}
}
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;
#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
}
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;
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
(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.
(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
(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
{
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) {
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);
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;
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)
#!./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
$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}?";
+}
+
}
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');
$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');
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}?";
+}
+
projects / platform / upstream / perl.git / commitdiff