4 ## Many of these tests are originally from Michael Schroeder
5 ## <Michael.Schroeder@informatik.uni-erlangen.de>
6 ## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com>
11 $Is_VMS = $^O eq 'VMS';
12 $Is_MSWin32 = $^O eq 'MSWin32';
13 $Is_NetWare = $^O eq 'NetWare';
14 $ENV{PERL5LIB} = "../lib" unless $Is_VMS;
19 @prgs = split "\n########\n", <DATA>;
20 print "1..", scalar @prgs, "\n";
22 $tmpfile = "runltmp000";
23 1 while -f ++$tmpfile;
24 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
31 my($prog,$expected) = split(/\nEXPECT\n/, $_);
32 open TEST, ">$tmpfile";
35 my $results = $Is_VMS ?
36 `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
38 `.\\perl -I../lib $switch $tmpfile 2>&1` :
40 `perl -I../lib $switch $tmpfile 2>&1` :
42 `$^X -I::lib -MMac::err=unix $switch $tmpfile` :
43 `./perl $switch $tmpfile 2>&1`;
46 # allow expected output to be written as if $prog is on STDIN
47 $results =~ s/runltmp\d+/-/g;
48 $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
49 $expected =~ s/\n+$//;
50 if ($results ne $expected) {
51 print STDERR "PROG: $switch\n$prog\n";
52 print STDERR "EXPECTED:\n$expected\n";
53 print STDERR "GOT:\n$results\n";
56 print "ok ", ++$i, "\n";
62 @a = sort { last ; } @a;
65 Can't "last" outside a loop block at - line 3.
75 print "still in fetch\n";
84 - >test at (eval 1) line 1.
116 print STDERR "PRINT CALLED\n";
117 (split(/./, 'x'x10000))[0];
118 eval('die("test\n")');
126 print STDERR "DONE\n";
133 eval('die("foooo\n")');
135 $SIG{'__WARN__'} = 'warnhook';
149 eval('die("test\n")');
155 $bar = bless {}, TEST;
163 $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
167 print join(', ', @a)."\n";
172 goto bar if $a == 0 || $b == 0;
177 print join(', ', @a)."\n";
180 print "bar reached\n";
182 Can't "goto" out of a pseudo block at - line 2.
186 (split(/./, 'x'x10000))[0];
187 my (@y) = ( 4, 6, 5);
188 @y = sort { $a <=> $b } @y;
189 my $t = "sortfn ".join(', ', @y)."\n";
190 print $t if ($seen{$t}++ == 0);
191 return $_[0] <=> $_[1];
194 @x = sort { &sortfn($a, $b) } @x;
195 print "---- ".join(', ', @x)."\n";
201 @a = sort { eval('die("no way")') , $a <=> $b} @a;
202 print join(", ", @a)."\n";
209 @a = sort { last foo; } @a;
212 Label not found for "last foo" at - line 2.
235 Can't "next" outside a loop block at - line 8.
256 Can't find label bbb at - line 8.
259 $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
263 print join(', ', @a)."\n";
276 (split(/./, 'x'x10000))[0];
293 Can't "next" outside a loop block at - line 4.
298 @a = sort { exit(0) } @a;
300 END { print "foobar\n" }
304 $SIG{__DIE__} = sub {
307 while (($p,$f,$l,$s) = caller(++$i)) {
308 print "$p|$f|$l|$s\n";
312 &{sub { eval 'die' }}();
313 sub foo { eval { die } } foo();
314 {package rmb; sub{ eval{die} } ->() }; # check __ANON__ is global
320 main|-|9|main::__ANON__
326 rmb|-|11|main::__ANON__
331 return bless [qw(foo fee fie foe)], $_[0];
344 print join('|', @bar[0..3]), "\n";
349 sub TIEHASH { bless {}, TH }
350 sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" }
352 eval { $h{A} = 1; print "never\n"; };
363 sub f { my $x = shift; d(); }
369 while (do { { package DB; @a = caller($i++) } } ) {
371 for (@a) { print "$_\n"; $_ = '' }