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
129
130
131
|
#!./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_MacOS = $^O eq 'MacOS';
$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_MacOS ?
`$^X -I::lib $switch $tmpfile` :
$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
|
