Commit | Line | Data |
---|---|---|
421f30ed | 1 | #!./perl |
421f30ed | 2 | |
f2ead8b8 | 3 | print "1..10\n"; |
421f30ed | 4 | |
e09ac076 | 5 | # Tests bug #22977. Test case from Dave Mitchell. |
421f30ed Z |
6 | sub f ($); |
7 | sub f ($) { | |
8 | my $test = $_[0]; | |
9 | write; | |
10 | format STDOUT = | |
11 | ok @<<<<<<< | |
12 | $test | |
13 | . | |
14 | } | |
15 | ||
16 | f(1); | |
17 | f(2); | |
e09ac076 FC |
18 | |
19 | # A bug caused by the fix for #22977/50528 | |
20 | sub foo { | |
21 | sub bar { | |
22 | # Fill the pad with alphabet soup, to give the closed-over variable a | |
23 | # high padoffset (more likely to trigger the bug and crash). | |
24 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
25 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
26 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
27 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
28 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
29 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
30 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
31 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
32 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
33 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
34 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
35 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
36 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
37 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
38 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
39 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
40 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
41 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
42 | my $x; | |
43 | format STDOUT2 = | |
44 | @<<<<<< | |
45 | "ok 3".$x # $x is not available, but this should not crash | |
46 | . | |
47 | } | |
48 | } | |
49 | *STDOUT = *STDOUT2{FORMAT}; | |
50 | undef *bar; | |
51 | write; | |
52 | ||
af41786f FC |
53 | # A regression introduced in 5.10; format cloning would close over the |
54 | # variables in the currently-running sub (the main CV in this test) if the | |
55 | # outer sub were an inactive closure. | |
56 | sub baz { | |
57 | my $a; | |
58 | sub { | |
59 | $a; | |
60 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t)} | |
61 | my $x; | |
62 | format STDOUT3 = | |
63 | @<<<<<<<<<<<<<<<<<<<<<<<<< | |
64 | defined $x ? "not ok 4 - $x" : "ok 4" | |
65 | . | |
66 | } | |
67 | } | |
68 | *STDOUT = *STDOUT3{FORMAT}; | |
69 | { | |
70 | local $^W = 1; | |
71 | my $w; | |
72 | local $SIG{__WARN__} = sub { $w = shift }; | |
73 | write; | |
74 | print "not " unless $w =~ /^Variable "\$x" is not available at/; | |
75 | print "ok 5 - closure var not available when outer sub is inactive\n"; | |
76 | } | |
70794f7b FC |
77 | |
78 | # Formats inside closures should close over the topmost clone of the outer | |
79 | # sub on the call stack. | |
80 | # Tests will be out of sequence if the wrong sub is used. | |
81 | sub make_closure { | |
82 | my $arg = shift; | |
83 | sub { | |
84 | shift == 0 and &$next(1), return; | |
85 | my $x = "ok $arg"; | |
86 | format STDOUT4 = | |
87 | @<<<<<<< | |
88 | $x | |
89 | . | |
90 | sub { write }->(); # separate sub, so as not to rely on it being the | |
91 | } # currently-running sub | |
92 | } | |
93 | *STDOUT = *STDOUT4{FORMAT}; | |
94 | $clo1 = make_closure 6; | |
95 | $clo2 = make_closure 7; | |
96 | $next = $clo1; | |
97 | &$clo2(0); | |
98 | $next = $clo2; | |
99 | &$clo1(0); | |
4a273b91 | 100 | |
f2ead8b8 FC |
101 | # Cloning a format whose outside has been undefined |
102 | sub x { | |
103 | {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} | |
104 | my $z; | |
105 | format STDOUT6 = | |
106 | @<<<<<<<<<<<<<<<<<<<<<<<<< | |
107 | defined $z ? "not ok 8 - $z" : "ok 8" | |
108 | . | |
109 | } | |
110 | undef &x; | |
111 | *STDOUT = *STDOUT6{FORMAT}; | |
112 | { | |
113 | local $^W = 1; | |
114 | my $w; | |
115 | local $SIG{__WARN__} = sub { $w = shift }; | |
116 | write; | |
117 | print "not " unless $w =~ /^Variable "\$z" is not available at/; | |
118 | print "ok 9 - closure var not available when outer sub is undefined\n"; | |
119 | } | |
120 | ||
4a273b91 FC |
121 | # This is a variation of bug #22977, which crashes or fails an assertion |
122 | # up to 5.16. | |
123 | # Keep this test last if you want test numbers to be sane. | |
124 | BEGIN { \&END } | |
125 | END { | |
f2ead8b8 | 126 | my $test = "ok 10"; |
4a273b91 FC |
127 | *STDOUT = *STDOUT5{FORMAT}; |
128 | write; | |
129 | format STDOUT5 = | |
130 | @<<<<<<< | |
131 | $test | |
132 | . | |
133 | } |