1N/A#!./perl
1N/A
1N/A# Note : we're not using t/test.pl here, because we would need
1N/A# fresh_perl_is, and fresh_perl_is uses a closure -- a special
1N/A# case of what this program tests for.
1N/A
1N/Achdir 't' if -d 't';
1N/A@INC = '../lib';
1N/A$Is_VMS = $^O eq 'VMS';
1N/A$Is_MSWin32 = $^O eq 'MSWin32';
1N/A$Is_MacOS = $^O eq 'MacOS';
1N/A$Is_NetWare = $^O eq 'NetWare';
1N/A$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
1N/A
1N/A$|=1;
1N/A
1N/Aundef $/;
1N/A@prgs = split "\n########\n", <DATA>;
1N/Aprint "1..", 6 + scalar @prgs, "\n";
1N/A
1N/A$tmpfile = "asubtmp000";
1N/A1 while -f ++$tmpfile;
1N/AEND { if ($tmpfile) { 1 while unlink $tmpfile; } }
1N/A
1N/Afor (@prgs){
1N/A my $switch = "";
1N/A if (s/^\s*(-\w+)//){
1N/A $switch = $1;
1N/A }
1N/A my($prog,$expected) = split(/\nEXPECT\n/, $_);
1N/A open TEST, ">$tmpfile";
1N/A print TEST "$prog\n";
1N/A close TEST or die "Could not close: $!";
1N/A my $results = $Is_VMS ?
1N/A `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
1N/A $Is_MSWin32 ?
1N/A `.\\perl -I../lib $switch $tmpfile 2>&1` :
1N/A $Is_MacOS ?
1N/A `$^X -I::lib $switch $tmpfile` :
1N/A $Is_NetWare ?
1N/A `perl -I../lib $switch $tmpfile 2>&1` :
1N/A `./perl $switch $tmpfile 2>&1`;
1N/A my $status = $?;
1N/A $results =~ s/\n+$//;
1N/A # allow expected output to be written as if $prog is on STDIN
1N/A $results =~ s/runltmp\d+/-/g;
1N/A $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
1N/A $expected =~ s/\n+$//;
1N/A if ($results ne $expected) {
1N/A print STDERR "PROG: $switch\n$prog\n";
1N/A print STDERR "EXPECTED:\n$expected\n";
1N/A print STDERR "GOT:\n$results\n";
1N/A print "not ";
1N/A }
1N/A print "ok ", ++$i, "\n";
1N/A}
1N/A
1N/Asub test_invalid_decl {
1N/A my ($code,$todo) = @_;
1N/A $todo = '' unless defined $todo;
1N/A eval $code;
1N/A if ($@ =~ /^Illegal declaration of anonymous subroutine at/) {
1N/A print "ok ", ++$i, " - '$code' is illegal$todo\n";
1N/A } else {
1N/A print "not ok ", ++$i, " - '$code' is illegal$todo\n# GOT: $@";
1N/A }
1N/A}
1N/A
1N/Atest_invalid_decl('sub;');
1N/Atest_invalid_decl('sub ($) ;');
1N/Atest_invalid_decl('{ $x = sub }');
1N/Atest_invalid_decl('sub ($) && 1');
1N/Atest_invalid_decl('sub ($) : lvalue;',' # TODO');
1N/A
1N/Aeval "sub #foo\n{print 1}";
1N/Aif ($@ eq '') {
1N/A print "ok ", ++$i, "\n";
1N/A} else {
1N/A print "not ok ", ++$i, "\n# GOT: $@";
1N/A}
1N/A
1N/A__END__
1N/Asub X {
1N/A my $n = "ok 1\n";
1N/A sub { print $n };
1N/A}
1N/Amy $x = X();
1N/Aundef &X;
1N/A$x->();
1N/AEXPECT
1N/Aok 1
1N/A########
1N/Asub X {
1N/A my $n = "ok 1\n";
1N/A sub {
1N/A my $dummy = $n; # eval can't close on $n without internal reference
1N/A eval 'print $n';
1N/A die $@ if $@;
1N/A };
1N/A}
1N/Amy $x = X();
1N/Aundef &X;
1N/A$x->();
1N/AEXPECT
1N/Aok 1
1N/A########
1N/Asub X {
1N/A my $n = "ok 1\n";
1N/A eval 'sub { print $n }';
1N/A}
1N/Amy $x = X();
1N/Adie $@ if $@;
1N/Aundef &X;
1N/A$x->();
1N/AEXPECT
1N/Aok 1
1N/A########
1N/Asub X;
1N/Asub X {
1N/A my $n = "ok 1\n";
1N/A eval 'sub Y { my $p = shift; $p->() }';
1N/A die $@ if $@;
1N/A Y(sub { print $n });
1N/A}
1N/AX();
1N/AEXPECT
1N/Aok 1
1N/A########
1N/Apackage;
1N/Aprint sub { return "ok 1\n" } -> ();
1N/AEXPECT
1N/Aok 1