This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[patch] blead@25282 - VMS specific fixes. [2nd try]
[perl5.git] / t / op / anonsub.t
CommitLineData
282f25c9
JH
1#!./perl
2
904d85c5
RGS
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
282f25c9
JH
7chdir 't' if -d 't';
8@INC = '../lib';
9$Is_VMS = $^O eq 'VMS';
10$Is_MSWin32 = $^O eq 'MSWin32';
95e8664e 11$Is_MacOS = $^O eq 'MacOS';
2986a63f 12$Is_NetWare = $^O eq 'NetWare';
282f25c9
JH
13$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
14
15$|=1;
16
17undef $/;
18@prgs = split "\n########\n", <DATA>;
904d85c5 19print "1..", 6 + scalar @prgs, "\n";
282f25c9
JH
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";
d1e4d418 33 close TEST or die "Could not close: $!";
282f25c9 34 my $results = $Is_VMS ?
16ed4686 35 `$^X "-I[-.lib]" $switch $tmpfile 2>&1` :
95e8664e
CN
36 $Is_MSWin32 ?
37 `.\\perl -I../lib $switch $tmpfile 2>&1` :
38 $Is_MacOS ?
39 `$^X -I::lib $switch $tmpfile` :
2986a63f
JH
40 $Is_NetWare ?
41 `perl -I../lib $switch $tmpfile 2>&1` :
42 `./perl $switch $tmpfile 2>&1`;
282f25c9
JH
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
904d85c5
RGS
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
282f25c9
JH
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
16920d4e 128########
16920d4e
RB
129print sub { return "ok 1\n" } -> ();
130EXPECT
131ok 1