4 ## all of these tests are from Michael Schroeder
5 ## <Michael.Schroeder@informatik.uni-erlangen.de>
7 ## The more esoteric failure modes require Michael's
8 ## stack-of-stacks patch (so we don't test them here,
9 ## and they are commented out before the __END__).
11 ## The remaining tests pass with a simpler fix
14 ## Gurusamy Sarathy <gsar@umich.edu> 97-02-24
19 $Is_VMS = $^O eq 'VMS';
20 $Is_MSWin32 = $^O eq 'MSWin32';
21 $ENV{PERL5LIB} = "../lib" unless $Is_VMS;
26 @prgs = split "\n########\n", <DATA>;
27 print "1..", scalar @prgs, "\n";
29 $tmpfile = "runltmp000";
30 1 while -f ++$tmpfile;
31 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
38 my($prog,$expected) = split(/\nEXPECT\n/, $_);
39 open TEST, ">$tmpfile";
42 my $results = $Is_VMS ?
43 `MCR $^X "-I[-.lib]" $switch $tmpfile` :
45 `.\\perl -I../lib $switch $tmpfile 2>&1` :
46 `sh -c './perl $switch $tmpfile' 2>&1`;
49 # allow expected output to be written as if $prog is on STDIN
50 $results =~ s/runltmp\d+/-/g;
51 $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
52 $expected =~ s/\n+$//;
53 if ($results ne $expected) {
54 print STDERR "PROG: $switch\n$prog\n";
55 print STDERR "EXPECTED:\n$expected\n";
56 print STDERR "GOT:\n$results\n";
59 print "ok ", ++$i, "\n";
62 =head2 stay out of here (the real tests are after __END__)
65 ## these tests don't pass yet (need the full stack-of-stacks patch)
72 (split(/./, 'x'x10000))[0];
74 @y = sort { $a <=> $b } @y;
75 print "sortfn ".join(', ', @y)."\n";
76 return $_[0] <=> $_[1];
79 @x = sort { &sortfn($a, $b) } @x;
80 print "---- ".join(', ', @x)."\n";
85 # trapping eval within sort (doesn't work currently because
86 # die does a SWITCHSTACK())
88 @a = sort { eval('die("no way")') , $a <=> $b} @a;
89 print join(", ", @a)."\n";
93 # this actually works fine, but results in a poor error message
97 @a = sort { last foo; } @a;
100 cannot reach destination block at - line 2.
123 cannot reach destination block at - line 8.
146 # trapping eval within sort (doesn't work currently because
147 # die does a SWITCHSTACK())
149 $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
153 print join(', ', @a)."\n";
168 cannot reach destination block at - line 4.
170 # large stack extension causes realloc, and segfault
180 (split(/./, 'x'x10000))[0];
190 ## The real tests begin here
197 @a = sort { last ; } @a;
200 Can't "last" outside a block at - line 3.
210 print "still in fetch\n";
219 - >test at (eval 1) line 1.
226 eval('die("foo\n")');
227 print "after eval\n";
251 print STDERR "PRINT CALLED\n";
252 (split(/./, 'x'x10000))[0];
253 eval('die("test\n")');
261 print STDERR "DONE\n";
268 eval('die("foooo\n")');
270 $SIG{'__WARN__'} = 'warnhook';
284 eval('die("test\n")');
290 $bar = bless {}, TEST;
298 $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
302 print join(', ', @a)."\n";
312 print join(', ', @a)."\n";
315 print "bar reached\n";
317 Can't "goto" outside a block at - line 2.