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