they seek him here, they seek him there
[perl.git] / t / op / range.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib', '.');
7 }   
8 # Avoid using eq_array below as it uses .. internally.
9
10 use Config;
11
12 plan (146);
13
14 is(join(':',1..5), '1:2:3:4:5');
15
16 @foo = (1,2,3,4,5,6,7,8,9);
17 @foo[2..4] = ('c','d','e');
18
19 is(join(':',@foo[$foo[0]..5]), '2:c:d:e:6');
20
21 @bar[2..4] = ('c','d','e');
22 is(join(':',@bar[1..5]), ':c:d:e:');
23
24 ($a,@bcd[0..2],$e) = ('a','b','c','d','e');
25 is(join(':',$a,@bcd[0..2],$e), 'a:b:c:d:e');
26
27 $x = 0;
28 for (1..100) {
29     $x += $_;
30 }
31 is($x, 5050);
32
33 $x = 0;
34 for ((100,2..99,1)) {
35     $x += $_;
36 }
37 is($x, 5050);
38
39 $x = join('','a'..'z');
40 is($x, 'abcdefghijklmnopqrstuvwxyz');
41
42 @x = 'A'..'ZZ';
43 is (scalar @x, 27 * 26);
44
45 foreach (0, 1) {
46     use feature 'unicode_strings';
47     $s = "a";
48     $e = "\xFF";
49     utf8::upgrade($e) if $_;
50     @x = $s .. $e;
51     is (scalar @x, 26, "list-context range with rhs 0xFF, utf8=$_");
52     @y = ();
53     foreach ($s .. $e) {
54         push @y, $_;
55     }
56     is(join(",", @y), join(",", @x), "foreach range with rhs 0xFF, utf8=$_");
57 }
58
59 @x = '09' .. '08';  # should produce '09', '10',... '99' (strange but true)
60 is(join(",", @x), join(",", map {sprintf "%02d",$_} 9..99));
61
62 # same test with foreach (which is a separate implementation)
63 @y = ();
64 foreach ('09'..'08') {
65     push(@y, $_);
66 }
67 is(join(",", @y), join(",", @x));
68
69 # check bounds
70 if ($Config{ivsize} == 8) {
71   @a = eval "0x7ffffffffffffffe..0x7fffffffffffffff";
72   $a = "9223372036854775806 9223372036854775807";
73   @b = eval "-0x7fffffffffffffff..-0x7ffffffffffffffe";
74   $b = "-9223372036854775807 -9223372036854775806";
75 }
76 else {
77   @a = eval "0x7ffffffe..0x7fffffff";
78   $a = "2147483646 2147483647";
79   @b = eval "-0x7fffffff..-0x7ffffffe";
80   $b = "-2147483647 -2147483646";
81 }
82
83 is ("@a", $a);
84
85 is ("@b", $b);
86
87 # check magic
88 {
89     my $bad = 0;
90     local $SIG{'__WARN__'} = sub { $bad = 1 };
91     my $x = 'a-e';
92     $x =~ s/(\w)-(\w)/join ':', $1 .. $2/e;
93     is ($x, 'a:b:c:d:e');
94 }
95
96 # Should use magical autoinc only when both are strings
97 {
98     my $scalar = (() = "0"..-1);
99     is ($scalar, 0);
100 }
101 {
102     my $fail = 0;
103     for my $x ("0"..-1) {
104         $fail++;
105     }
106     is ($fail, 0);
107 }
108
109 # [#18165] Should allow "-4".."0", broken by #4730. (AMS 20021031)
110 is(join(":","-4".."0")     , "-4:-3:-2:-1:0");
111 is(join(":","-4".."-0")    , "-4:-3:-2:-1:0");
112 is(join(":","-4\n".."0\n") , "-4:-3:-2:-1:0");
113 is(join(":","-4\n".."-0\n"), "-4:-3:-2:-1:0");
114
115 # undef should be treated as 0 for numerical range
116 is(join(":",undef..2), '0:1:2');
117 is(join(":",-2..undef), '-2:-1:0');
118 is(join(":",undef..'2'), '0:1:2');
119 is(join(":",'-2'..undef), '-2:-1:0');
120
121 # undef should be treated as "" for magical range
122 is(join(":", map "[$_]", "".."B"), '[]');
123 is(join(":", map "[$_]", undef.."B"), '[]');
124 is(join(":", map "[$_]", "B"..""), '');
125 is(join(":", map "[$_]", "B"..undef), '');
126
127 # undef..undef used to segfault
128 is(join(":", map "[$_]", undef..undef), '[]');
129
130 # also test undef in foreach loops
131 @foo=(); push @foo, $_ for undef..2;
132 is(join(":", @foo), '0:1:2');
133
134 @foo=(); push @foo, $_ for -2..undef;
135 is(join(":", @foo), '-2:-1:0');
136
137 @foo=(); push @foo, $_ for undef..'2';
138 is(join(":", @foo), '0:1:2');
139
140 @foo=(); push @foo, $_ for '-2'..undef;
141 is(join(":", @foo), '-2:-1:0');
142
143 @foo=(); push @foo, $_ for undef.."B";
144 is(join(":", map "[$_]", @foo), '[]');
145
146 @foo=(); push @foo, $_ for "".."B";
147 is(join(":", map "[$_]", @foo), '[]');
148
149 @foo=(); push @foo, $_ for "B"..undef;
150 is(join(":", map "[$_]", @foo), '');
151
152 @foo=(); push @foo, $_ for "B".."";
153 is(join(":", map "[$_]", @foo), '');
154
155 @foo=(); push @foo, $_ for undef..undef;
156 is(join(":", map "[$_]", @foo), '[]');
157
158 # again with magic
159 {
160     my @a = (1..3);
161     @foo=(); push @foo, $_ for undef..$#a;
162     is(join(":", @foo), '0:1:2');
163 }
164 {
165     my @a = ();
166     @foo=(); push @foo, $_ for $#a..undef;
167     is(join(":", @foo), '-1:0');
168 }
169 {
170     local $1;
171     "2" =~ /(.+)/;
172     @foo=(); push @foo, $_ for undef..$1;
173     is(join(":", @foo), '0:1:2');
174 }
175 {
176     local $1;
177     "-2" =~ /(.+)/;
178     @foo=(); push @foo, $_ for $1..undef;
179     is(join(":", @foo), '-2:-1:0');
180 }
181 {
182     local $1;
183     "B" =~ /(.+)/;
184     @foo=(); push @foo, $_ for undef..$1;
185     is(join(":", map "[$_]", @foo), '[]');
186 }
187 {
188     local $1;
189     "B" =~ /(.+)/;
190     @foo=(); push @foo, $_ for ""..$1;
191     is(join(":", map "[$_]", @foo), '[]');
192 }
193 {
194     local $1;
195     "B" =~ /(.+)/;
196     @foo=(); push @foo, $_ for $1..undef;
197     is(join(":", map "[$_]", @foo), '');
198 }
199 {
200     local $1;
201     "B" =~ /(.+)/;
202     @foo=(); push @foo, $_ for $1.."";
203     is(join(":", map "[$_]", @foo), '');
204 }
205
206 # Test upper range limit
207 my $MAX_INT = ~0>>1;
208
209 foreach my $ii (-3 .. 3) {
210     my ($first, $last);
211     eval {
212         my $lim=0;
213         for ($MAX_INT-10 .. $MAX_INT+$ii) {
214             if (! defined($first)) {
215                 $first = $_;
216             }
217             $last = $_;
218             last if ($lim++ > 100);   # Protect against integer wrap
219         }
220     };
221     if ($ii <= 0) {
222         ok(! $@, 'Upper bound accepted: ' . ($MAX_INT+$ii));
223         is($first, $MAX_INT-10, 'Lower bound okay');
224         is($last, $MAX_INT+$ii, 'Upper bound okay');
225     } else {
226         ok($@, 'Upper bound rejected: ' . ($MAX_INT+$ii));
227     }
228 }
229
230 foreach my $ii (-3 .. 3) {
231     my ($first, $last);
232     eval {
233         my $lim=0;
234         for ($MAX_INT+$ii .. $MAX_INT) {
235             if (! defined($first)) {
236                 $first = $_;
237             }
238             $last = $_;
239             last if ($lim++ > 100);
240         }
241     };
242     if ($ii <= 0) {
243         ok(! $@, 'Lower bound accepted: ' . ($MAX_INT+$ii));
244         is($first, $MAX_INT+$ii, 'Lower bound okay');
245         is($last, $MAX_INT, 'Upper bound okay');
246     } else {
247         ok($@, 'Lower bound rejected: ' . ($MAX_INT+$ii));
248     }
249 }
250
251 {
252     my $first;
253     eval {
254         my $lim=0;
255         for ($MAX_INT .. $MAX_INT-1) {
256             if (! defined($first)) {
257                 $first = $_;
258             }
259             $last = $_;
260             last if ($lim++ > 100);
261         }
262     };
263     ok(! $@, 'Range accepted');
264     ok(! defined($first), 'Range ineffectual');
265 }
266
267 foreach my $ii (~0, ~0+1, ~0+(~0>>4)) {
268     eval {
269         my $lim=0;
270         for ($MAX_INT-10 .. $ii) {
271             last if ($lim++ > 100);
272         }
273     };
274     ok($@, 'Upper bound rejected: ' . $ii);
275 }
276
277 # Test lower range limit
278 my $MIN_INT = -1-$MAX_INT;
279
280 if (! $Config{d_nv_preserves_uv}) {
281     # $MIN_INT needs adjustment when IV won't fit into an NV
282     my $NV = $MIN_INT - 1;
283     my $OFFSET = 1;
284     while (($NV + $OFFSET) == $MIN_INT) {
285         $OFFSET++
286     }
287     $MIN_INT += $OFFSET;
288 }
289
290 foreach my $ii (-3 .. 3) {
291     my ($first, $last);
292     eval {
293         my $lim=0;
294         for ($MIN_INT+$ii .. $MIN_INT+10) {
295             if (! defined($first)) {
296                 $first = $_;
297             }
298             $last = $_;
299             last if ($lim++ > 100);
300         }
301     };
302     if ($ii >= 0) {
303         ok(! $@, 'Lower bound accepted: ' . ($MIN_INT+$ii));
304         is($first, $MIN_INT+$ii, 'Lower bound okay');
305         is($last, $MIN_INT+10, 'Upper bound okay');
306     } else {
307         ok($@, 'Lower bound rejected: ' . ($MIN_INT+$ii));
308     }
309 }
310
311 foreach my $ii (-3 .. 3) {
312     my ($first, $last);
313     eval {
314         my $lim=0;
315         for ($MIN_INT .. $MIN_INT+$ii) {
316             if (! defined($first)) {
317                 $first = $_;
318             }
319             $last = $_;
320             last if ($lim++ > 100);
321         }
322     };
323     if ($ii >= 0) {
324         ok(! $@, 'Upper bound accepted: ' . ($MIN_INT+$ii));
325         is($first, $MIN_INT, 'Lower bound okay');
326         is($last, $MIN_INT+$ii, 'Upper bound okay');
327     } else {
328         ok($@, 'Upper bound rejected: ' . ($MIN_INT+$ii));
329     }
330 }
331
332 {
333     my $first;
334     eval {
335         my $lim=0;
336         for ($MIN_INT+1 .. $MIN_INT) {
337             if (! defined($first)) {
338                 $first = $_;
339             }
340             $last = $_;
341             last if ($lim++ > 100);
342         }
343     };
344     ok(! $@, 'Range accepted');
345     ok(! defined($first), 'Range ineffectual');
346 }
347
348 foreach my $ii (~0, ~0+1, ~0+(~0>>4)) {
349     eval {
350         my $lim=0;
351         for (-$ii .. $MIN_INT+10) {
352             last if ($lim++ > 100);
353         }
354     };
355     ok($@, 'Lower bound rejected: ' . -$ii);
356 }
357
358 # double/triple magic tests
359 sub TIESCALAR { bless { value => $_[1], orig => $_[1] } }
360 sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] }
361 sub FETCH { $_[0]{fetch}++; $_[0]{value} }
362 sub stores { tied($_[0])->{value} = tied($_[0])->{orig};
363              delete(tied($_[0])->{store}) || 0 }
364 sub fetches { delete(tied($_[0])->{fetch}) || 0 }
365     
366 tie $x, "main", 6;
367
368 my @foo;
369 @foo = 4 .. $x;
370 is(scalar @foo, 3);
371 is("@foo", "4 5 6");
372 is(fetches($x), 1);
373 is(stores($x), 0);
374
375 @foo = $x .. 8;
376 is(scalar @foo, 3);
377 is("@foo", "6 7 8");
378 is(fetches($x), 1);
379 is(stores($x), 0);
380
381 @foo = $x .. $x + 1;
382 is(scalar @foo, 2);
383 is("@foo", "6 7");
384 is(fetches($x), 2);
385 is(stores($x), 0);
386
387 @foo = ();
388 for (4 .. $x) {
389   push @foo, $_;
390 }
391 is(scalar @foo, 3);
392 is("@foo", "4 5 6");
393 is(fetches($x), 1);
394 is(stores($x), 0);
395
396 @foo = ();
397 for (reverse 4 .. $x) {
398   push @foo, $_;
399 }
400 is(scalar @foo, 3);
401 is("@foo", "6 5 4");
402 is(fetches($x), 1);
403 is(stores($x), 0);
404
405 is( ( join ' ', map { join '', map ++$_, ($x=1)..4 } 1..2 ), '2345 2345',
406     'modifiable variable num range' );
407 is( ( join ' ', map { join '', map ++$_, 1..4      } 1..2 ), '2345 2345',
408     'modifiable const num range' );  # RT#3105
409 $s = ''; for (1..2) { for (1..4) { $s .= ++$_ } $s.=' ' if $_==1; }
410 is( $s, '2345 2345','modifiable num counting loop counter' );
411
412
413 is( ( join ' ', map { join '', map ++$_, ($x='a')..'d' } 1..2 ), 'bcde bcde',
414     'modifiable variable alpha range' );
415 is( ( join ' ', map { join '', map ++$_, 'a'..'d'      } 1..2 ), 'bcde bcde',
416     'modifiable const alpha range' );  # RT#3105
417 $s = ''; for (1..2) { for ('a'..'d') { $s .= ++$_ } $s.=' ' if $_==1; }
418 is( $s, 'bcde bcde','modifiable alpha counting loop counter' );
419
420 # RT #130841
421 # generating an extreme range triggered a croak, which if caught,
422 # left the temps stack small but with a very large PL_tmps_max
423
424 SKIP: {
425     skip 'mem wrap check disabled' unless $Config{usemallocwrap};
426     fresh_perl_like(<<'EOF', qr/\Aok 1 ok 2\Z/, {}, "RT #130841");
427 my $max_iv = (~0 >> 1);
428 eval {
429     my @range = 1..($max_iv - 1);
430 };
431 if ($@ =~ /panic: memory wrap|Out of memory/) {
432     print "ok 1";
433 }
434 else {
435     print "unexpected err status: [$@]";
436 }
437
438 # create and push lots of temps
439 my $max = 10_000;
440 my @ints = map $_+1, 0..($max-1);
441 my $sum = 0;
442 $sum += $_ for @ints;
443 my $exp = $max*($max+1)/2;
444 if ($sum == $exp) {
445     print " ok 2";
446 }
447 else {
448     print " unexpected sum: [$sum]; expected: [$exp]";
449 }
450 EOF
451 }