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