Commit | Line | Data |
282f25c9 |
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 |