1#!./perl 2 3## 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> 7## 8 9chdir 't' if -d 't'; 10@INC = '../lib'; 11$Is_VMS = $^O eq 'VMS'; 12$Is_MSWin32 = $^O eq 'MSWin32'; 13$Is_NetWare = $^O eq 'NetWare'; 14$Is_MacOS = $^O eq 'MacOS'; 15$ENV{PERL5LIB} = "../lib" unless $Is_VMS; 16 17$|=1; 18 19undef $/; 20@prgs = split "\n########\n", <DATA>; 21print "1..", scalar @prgs, "\n"; 22 23$tmpfile = "runltmp000"; 241 while -f ++$tmpfile; 25END { if ($tmpfile) { 1 while unlink $tmpfile; } } 26 27for (@prgs){ 28 my $switch = ""; 29 if (s/^\s*(-\w+)//){ 30 $switch = $1; 31 } 32 my($prog,$expected) = split(/\nEXPECT\n/, $_); 33 open TEST, ">$tmpfile"; 34 print TEST "$prog\n"; 35 close TEST or die "Could not close: $!"; 36 my $results = $Is_VMS ? 37 `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : 38 $Is_MSWin32 ? 39 `.\\perl -I../lib $switch $tmpfile 2>&1` : 40 $Is_NetWare ? 41 `perl -I../lib $switch $tmpfile 2>&1` : 42 $Is_MacOS ? 43 `$^X -I::lib -MMac::err=unix $switch $tmpfile` : 44 `./perl $switch $tmpfile 2>&1`; 45 my $status = $?; 46 $results =~ s/\n+$//; 47 # allow expected output to be written as if $prog is on STDIN 48 $results =~ s/runltmp\d+/-/g; 49 $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg 50 $expected =~ s/\n+$//; 51 if ($results ne $expected) { 52 print STDERR "PROG: $switch\n$prog\n"; 53 print STDERR "EXPECTED:\n$expected\n"; 54 print STDERR "GOT:\n$results\n"; 55 print "not "; 56 } 57 print "ok ", ++$i, "\n"; 58} 59 60__END__ 61@a = (1, 2, 3); 62{ 63 @a = sort { last ; } @a; 64} 65EXPECT 66Can't "last" outside a loop block at - line 3. 67######## 68package TEST; 69 70sub TIESCALAR { 71 my $foo; 72 return bless \$foo; 73} 74sub FETCH { 75 eval 'die("test")'; 76 print "still in fetch\n"; 77 return ">$@<"; 78} 79package main; 80 81tie $bar, TEST; 82print "- $bar\n"; 83EXPECT 84still in fetch 85- >test at (eval 1) line 1. 86< 87######## 88package TEST; 89 90sub TIESCALAR { 91 my $foo; 92 eval('die("foo\n")'); 93 print "after eval\n"; 94 return bless \$foo; 95} 96sub FETCH { 97 return "ZZZ"; 98} 99 100package main; 101 102tie $bar, TEST; 103print "- $bar\n"; 104print "OK\n"; 105EXPECT 106after eval 107- ZZZ 108OK 109######## 110package TEST; 111 112sub TIEHANDLE { 113 my $foo; 114 return bless \$foo; 115} 116sub PRINT { 117print STDERR "PRINT CALLED\n"; 118(split(/./, 'x'x10000))[0]; 119eval('die("test\n")'); 120} 121 122package main; 123 124open FH, ">&STDOUT"; 125tie *FH, TEST; 126print FH "OK\n"; 127print STDERR "DONE\n"; 128EXPECT 129PRINT CALLED 130DONE 131######## 132sub warnhook { 133 print "WARNHOOK\n"; 134 eval('die("foooo\n")'); 135} 136$SIG{'__WARN__'} = 'warnhook'; 137warn("dfsds\n"); 138print "END\n"; 139EXPECT 140WARNHOOK 141END 142######## 143package TEST; 144 145use overload 146 "\"\"" => \&str 147; 148 149sub str { 150 eval('die("test\n")'); 151 return "STR"; 152} 153 154package main; 155 156$bar = bless {}, TEST; 157print "$bar\n"; 158print "OK\n"; 159EXPECT 160STR 161OK 162######## 163sub foo { 164 $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); 165} 166@a = (3, 2, 0, 1); 167@a = sort foo @a; 168print join(', ', @a)."\n"; 169EXPECT 1700, 1, 2, 3 171######## 172sub foo { 173 goto bar if $a == 0 || $b == 0; 174 $a <=> $b; 175} 176@a = (3, 2, 0, 1); 177@a = sort foo @a; 178print join(', ', @a)."\n"; 179exit; 180bar: 181print "bar reached\n"; 182EXPECT 183Can't "goto" out of a pseudo block at - line 2. 184######## 185%seen = (); 186sub sortfn { 187 (split(/./, 'x'x10000))[0]; 188 my (@y) = ( 4, 6, 5); 189 @y = sort { $a <=> $b } @y; 190 my $t = "sortfn ".join(', ', @y)."\n"; 191 print $t if ($seen{$t}++ == 0); 192 return $_[0] <=> $_[1]; 193} 194@x = ( 3, 2, 1 ); 195@x = sort { &sortfn($a, $b) } @x; 196print "---- ".join(', ', @x)."\n"; 197EXPECT 198sortfn 4, 5, 6 199---- 1, 2, 3 200######## 201@a = (3, 2, 1); 202@a = sort { eval('die("no way")') , $a <=> $b} @a; 203print join(", ", @a)."\n"; 204EXPECT 2051, 2, 3 206######## 207@a = (1, 2, 3); 208foo: 209{ 210 @a = sort { last foo; } @a; 211} 212EXPECT 213Label not found for "last foo" at - line 2. 214######## 215package TEST; 216 217sub TIESCALAR { 218 my $foo; 219 return bless \$foo; 220} 221sub FETCH { 222 next; 223 return "ZZZ"; 224} 225sub STORE { 226} 227 228package main; 229 230tie $bar, TEST; 231{ 232 print "- $bar\n"; 233} 234print "OK\n"; 235EXPECT 236Can't "next" outside a loop block at - line 8. 237######## 238package TEST; 239 240sub TIESCALAR { 241 my $foo; 242 return bless \$foo; 243} 244sub FETCH { 245 goto bbb; 246 return "ZZZ"; 247} 248 249package main; 250 251tie $bar, TEST; 252print "- $bar\n"; 253exit; 254bbb: 255print "bbb\n"; 256EXPECT 257Can't find label bbb at - line 8. 258######## 259sub foo { 260 $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); 261} 262@a = (3, 2, 0, 1); 263@a = sort foo @a; 264print join(', ', @a)."\n"; 265EXPECT 2660, 1, 2, 3 267######## 268package TEST; 269sub TIESCALAR { 270 my $foo; 271 return bless \$foo; 272} 273sub FETCH { 274 return "fetch"; 275} 276sub STORE { 277(split(/./, 'x'x10000))[0]; 278} 279package main; 280tie $bar, TEST; 281$bar = "x"; 282######## 283package TEST; 284sub TIESCALAR { 285 my $foo; 286 next; 287 return bless \$foo; 288} 289package main; 290{ 291tie $bar, TEST; 292} 293EXPECT 294Can't "next" outside a loop block at - line 4. 295######## 296@a = (1, 2, 3); 297foo: 298{ 299 @a = sort { exit(0) } @a; 300} 301END { print "foobar\n" } 302EXPECT 303foobar 304######## 305$SIG{__DIE__} = sub { 306 print "In DIE\n"; 307 $i = 0; 308 while (($p,$f,$l,$s) = caller(++$i)) { 309 print "$p|$f|$l|$s\n"; 310 } 311}; 312eval { die }; 313&{sub { eval 'die' }}(); 314sub foo { eval { die } } foo(); 315{package rmb; sub{ eval{die} } ->() }; # check __ANON__ knows package 316EXPECT 317In DIE 318main|-|8|(eval) 319In DIE 320main|-|9|(eval) 321main|-|9|main::__ANON__ 322In DIE 323main|-|10|(eval) 324main|-|10|main::foo 325In DIE 326rmb|-|11|(eval) 327rmb|-|11|rmb::__ANON__ 328######## 329package TEST; 330 331sub TIEARRAY { 332 return bless [qw(foo fee fie foe)], $_[0]; 333} 334sub FETCH { 335 my ($s,$i) = @_; 336 if ($i) { 337 goto bbb; 338 } 339bbb: 340 return $s->[$i]; 341} 342 343package main; 344tie my @bar, 'TEST'; 345print join('|', @bar[0..3]), "\n"; 346EXPECT 347foo|fee|fie|foe 348######## 349package TH; 350sub TIEHASH { bless {}, TH } 351sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" } 352tie %h, TH; 353eval { $h{A} = 1; print "never\n"; }; 354print $@; 355eval { $h{B} = 2; }; 356print $@; 357EXPECT 358A 1 359bar 360B 2 361bar 362######## 363sub n { 0 } 364sub f { my $x = shift; d(); } 365f(n()); 366f(); 367 368sub d { 369 my $i = 0; my @a; 370 while (do { { package DB; @a = caller($i++) } } ) { 371 @a = @DB::args; 372 for (@a) { print "$_\n"; $_ = '' } 373 } 374} 375EXPECT 3760 377######## 378sub TIEHANDLE { bless {} } 379sub PRINT { next } 380 381tie *STDERR, ''; 382{ map ++$_, 1 } 383 384EXPECT 385Can't "next" outside a loop block at - line 2. 386######## 387sub TIEHANDLE { bless {} } 388sub PRINT { print "[TIE] $_[1]" } 389 390tie *STDERR, ''; 391die "DIE\n"; 392 393EXPECT 394[TIE] DIE 395######## 396sub TIEHANDLE { bless {} } 397sub PRINT { 398 (split(/./, 'x'x10000))[0]; 399 eval('die("test\n")'); 400 warn "[TIE] $_[1]"; 401} 402open OLDERR, '>&STDERR'; 403tie *STDERR, ''; 404 405use warnings FATAL => qw(uninitialized); 406print undef; 407 408EXPECT 409[TIE] Use of uninitialized value in print at - line 11. 410