1#!./perl 2 3# Note : we're not using t/test.pl here, because we would need 4# fresh_perl_is, and fresh_perl_is uses a closure -- a special 5# case of what this program tests for. 6 7chdir 't' if -d 't'; 8@INC = '../lib'; 9$Is_VMS = $^O eq 'VMS'; 10$Is_MSWin32 = $^O eq 'MSWin32'; 11$Is_MacOS = $^O eq 'MacOS'; 12$Is_NetWare = $^O eq 'NetWare'; 13$ENV{PERL5LIB} = "../lib" unless $Is_VMS; 14 15$|=1; 16 17undef $/; 18@prgs = split "\n########\n", <DATA>; 19print "1..", 6 + scalar @prgs, "\n"; 20 21$tmpfile = "asubtmp000"; 221 while -f ++$tmpfile; 23END { if ($tmpfile) { 1 while unlink $tmpfile; } } 24 25for (@prgs){ 26 my $switch = ""; 27 if (s/^\s*(-\w+)//){ 28 $switch = $1; 29 } 30 my($prog,$expected) = split(/\nEXPECT\n/, $_); 31 open TEST, ">$tmpfile"; 32 print TEST "$prog\n"; 33 close TEST or die "Could not close: $!"; 34 my $results = $Is_VMS ? 35 `$^X "-I[-.lib]" $switch $tmpfile 2>&1` : 36 $Is_MSWin32 ? 37 `.\\perl -I../lib $switch $tmpfile 2>&1` : 38 $Is_MacOS ? 39 `$^X -I::lib $switch $tmpfile` : 40 $Is_NetWare ? 41 `perl -I../lib $switch $tmpfile 2>&1` : 42 `./perl $switch $tmpfile 2>&1`; 43 my $status = $?; 44 $results =~ s/\n+$//; 45 # allow expected output to be written as if $prog is on STDIN 46 $results =~ s/runltmp\d+/-/g; 47 $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg 48 $expected =~ s/\n+$//; 49 if ($results ne $expected) { 50 print STDERR "PROG: $switch\n$prog\n"; 51 print STDERR "EXPECTED:\n$expected\n"; 52 print STDERR "GOT:\n$results\n"; 53 print "not "; 54 } 55 print "ok ", ++$i, "\n"; 56} 57 58sub test_invalid_decl { 59 my ($code,$todo) = @_; 60 $todo //= ''; 61 eval $code; 62 if ($@ =~ /^Illegal declaration of anonymous subroutine at/) { 63 print "ok ", ++$i, " - '$code' is illegal$todo\n"; 64 } else { 65 print "not ok ", ++$i, " - '$code' is illegal$todo\n# GOT: $@"; 66 } 67} 68 69test_invalid_decl('sub;'); 70test_invalid_decl('sub ($) ;'); 71test_invalid_decl('{ $x = sub }'); 72test_invalid_decl('sub ($) && 1'); 73test_invalid_decl('sub ($) : lvalue;',' # TODO'); 74 75eval "sub #foo\n{print 1}"; 76if ($@ eq '') { 77 print "ok ", ++$i, "\n"; 78} else { 79 print "not ok ", ++$i, "\n# GOT: $@"; 80} 81 82__END__ 83sub X { 84 my $n = "ok 1\n"; 85 sub { print $n }; 86} 87my $x = X(); 88undef &X; 89$x->(); 90EXPECT 91ok 1 92######## 93sub X { 94 my $n = "ok 1\n"; 95 sub { 96 my $dummy = $n; # eval can't close on $n without internal reference 97 eval 'print $n'; 98 die $@ if $@; 99 }; 100} 101my $x = X(); 102undef &X; 103$x->(); 104EXPECT 105ok 1 106######## 107sub X { 108 my $n = "ok 1\n"; 109 eval 'sub { print $n }'; 110} 111my $x = X(); 112die $@ if $@; 113undef &X; 114$x->(); 115EXPECT 116ok 1 117######## 118sub X; 119sub X { 120 my $n = "ok 1\n"; 121 eval 'sub Y { my $p = shift; $p->() }'; 122 die $@ if $@; 123 Y(sub { print $n }); 124} 125X(); 126EXPECT 127ok 1 128######## 129print sub { return "ok 1\n" } -> (); 130EXPECT 131ok 1 132