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 $ENV{PERL5LIB} = "../lib";
24 @prgs = split "\n########\n", <DATA>;
25 print "1..", scalar @prgs, "\n";
27 $tmpfile = "runltmp000";
28 1 while -f ++$tmpfile;
29 END { unlink $tmpfile if $tmpfile; }
36 my($prog,$expected) = split(/\nEXPECT\n/, $_);
37 open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1";
38 print TEST $prog, "\n";
41 $results = `cat $tmpfile`;
43 $expected =~ s/\n+$//;
44 if ( $results ne $expected){
45 print STDERR "PROG: $switch\n$prog\n";
46 print STDERR "EXPECTED:\n$expected\n";
47 print STDERR "GOT:\n$results\n";
50 print "ok ", ++$i, "\n";
53 =head2 stay out of here (the real tests are after __END__)
56 ## these tests don't pass yet (need the full stack-of-stacks patch)
63 (split(/./, 'x'x10000))[0];
65 @y = sort { $a <=> $b } @y;
66 print "sortfn ".join(', ', @y)."\n";
67 return $_[0] <=> $_[1];
70 @x = sort { &sortfn($a, $b) } @x;
71 print "---- ".join(', ', @x)."\n";
76 # trapping eval within sort (doesn't work currently because
77 # die does a SWITCHSTACK())
79 @a = sort { eval('die("no way")') , $a <=> $b} @a;
80 print join(", ", @a)."\n";
84 # this actually works fine, but results in a poor error message
88 @a = sort { last foo; } @a;
91 cannot reach destination block at - line 2.
114 cannot reach destination block at - line 8.
137 # trapping eval within sort (doesn't work currently because
138 # die does a SWITCHSTACK())
140 $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
144 print join(', ', @a)."\n";
159 cannot reach destination block at - line 4.
161 # large stack extension causes realloc, and segfault
171 (split(/./, 'x'x10000))[0];
181 ## The real tests begin here
188 @a = sort { last ; } @a;
191 Can't "last" outside a block at - line 3.
201 print "still in fetch\n";
210 - >test at (eval 1) line 1.
217 eval('die("foo\n")');
218 print "after eval\n";
242 print STDERR "PRINT CALLED\n";
243 (split(/./, 'x'x10000))[0];
244 eval('die("test\n")');
259 eval('die("foooo\n")');
261 $SIG{'__WARN__'} = 'warnhook';
275 eval('die("test\n")');
281 $bar = bless {}, TEST;
289 $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
293 print join(', ', @a)."\n";
303 print join(', ', @a)."\n";
306 print "bar reached\n";
308 Can't "goto" outside a block at - line 2.