This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate change #9108 from maintperl to mainline.
[perl5.git] / t / op / anonsub.t
1 #!./perl
2
3 chdir 't' if -d 't';
4 @INC = '../lib';
5 $Is_VMS = $^O eq 'VMS';
6 $Is_MSWin32 = $^O eq 'MSWin32';
7 $ENV{PERL5LIB} = "../lib" unless $Is_VMS;
8
9 $|=1;
10
11 undef $/;
12 @prgs = split "\n########\n", <DATA>;
13 print "1..", scalar @prgs, "\n";
14
15 $tmpfile = "asubtmp000";
16 1 while -f ++$tmpfile;
17 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
18
19 for (@prgs){
20     my $switch = "";
21     if (s/^\s*(-\w+)//){
22        $switch = $1;
23     }
24     my($prog,$expected) = split(/\nEXPECT\n/, $_);
25     open TEST, ">$tmpfile";
26     print TEST "$prog\n";
27     close TEST;
28     my $results = $Is_VMS ?
29                   `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
30                       $Is_MSWin32 ?  
31                           `.\\perl -I../lib $switch $tmpfile 2>&1` :
32                               `./perl $switch $tmpfile 2>&1`;
33     my $status = $?;
34     $results =~ s/\n+$//;
35     # allow expected output to be written as if $prog is on STDIN
36     $results =~ s/runltmp\d+/-/g;
37     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
38     $expected =~ s/\n+$//;
39     if ($results ne $expected) {
40        print STDERR "PROG: $switch\n$prog\n";
41        print STDERR "EXPECTED:\n$expected\n";
42        print STDERR "GOT:\n$results\n";
43        print "not ";
44     }
45     print "ok ", ++$i, "\n";
46 }
47
48 __END__
49 sub X {
50     my $n = "ok 1\n";
51     sub { print $n };
52 }
53 my $x = X();
54 undef &X;
55 $x->();
56 EXPECT
57 ok 1
58 ########
59 sub X {
60     my $n = "ok 1\n";
61     sub {
62         my $dummy = $n; # eval can't close on $n without internal reference
63         eval 'print $n';
64         die $@ if $@;
65     };
66 }
67 my $x = X();
68 undef &X;
69 $x->();
70 EXPECT
71 ok 1
72 ########
73 sub X {
74     my $n = "ok 1\n";
75     eval 'sub { print $n }';
76 }
77 my $x = X();
78 die $@ if $@;
79 undef &X;
80 $x->();
81 EXPECT
82 ok 1
83 ########
84 sub X;
85 sub X {
86     my $n = "ok 1\n";
87     eval 'sub Y { my $p = shift; $p->() }';
88     die $@ if $@;
89     Y(sub { print $n });
90 }
91 X();
92 EXPECT
93 ok 1