Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / anonsub.t
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
7 chdir '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
17 undef $/;
18 @prgs = split "\n########\n", <DATA>;
19 print "1..", 6 + scalar @prgs, "\n";
20
21 $tmpfile = "asubtmp000";
22 1 while -f ++$tmpfile;
23 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
24
25 for (@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
58 sub 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
69 test_invalid_decl('sub;');
70 test_invalid_decl('sub ($) ;');
71 test_invalid_decl('{ $x = sub }');
72 test_invalid_decl('sub ($) && 1');
73 test_invalid_decl('sub ($) : lvalue;',' # TODO');
74
75 eval "sub #foo\n{print 1}";
76 if ($@ eq '') {
77     print "ok ", ++$i, "\n";
78 } else {
79     print "not ok ", ++$i, "\n# GOT: $@";
80 }
81
82 __END__
83 sub X {
84     my $n = "ok 1\n";
85     sub { print $n };
86 }
87 my $x = X();
88 undef &X;
89 $x->();
90 EXPECT
91 ok 1
92 ########
93 sub 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 }
101 my $x = X();
102 undef &X;
103 $x->();
104 EXPECT
105 ok 1
106 ########
107 sub X {
108     my $n = "ok 1\n";
109     eval 'sub { print $n }';
110 }
111 my $x = X();
112 die $@ if $@;
113 undef &X;
114 $x->();
115 EXPECT
116 ok 1
117 ########
118 sub X;
119 sub X {
120     my $n = "ok 1\n";
121     eval 'sub Y { my $p = shift; $p->() }';
122     die $@ if $@;
123     Y(sub { print $n });
124 }
125 X();
126 EXPECT
127 ok 1
128 ########
129 print sub { return "ok 1\n" } -> ();
130 EXPECT
131 ok 1