1#!./perl
2
3print "1..14\n";
4
5# Tests bug #22977.  Test case from Dave Mitchell.
6sub f ($);
7sub f ($) {
8my $test = $_[0];
9write;
10format STDOUT =
11ok @<<<<<<<
12$test
13.
14}
15
16f(1);
17f(2);
18
19# A bug caused by the fix for #22977/50528
20sub 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};
50undef *bar;
51write;
52
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.
56sub 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@<<<<<<<<<<<<<<<<<<<<<<<<<
64defined $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}
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.
81sub 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);
100
101# Cloning a format whose outside has been undefined
102sub 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@<<<<<<<<<<<<<<<<<<<<<<<<<
107defined $z ? "not ok 8 - $z" : "ok 8"
108.
109}
110undef &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
121format STDOUT7 =
122@<<<<<<<<<<<<<<<<<<<<<<<<<<<
123do { my $x = "ok 10 - closure inside format"; sub { $x }->() }
124.
125*STDOUT = *STDOUT7{FORMAT};
126write;
127
128$testn = 12;
129format STDOUT8 =
130@<<<< - recursive formats
131do { my $t = "ok " . $testn--; write if $t =~ 12; $t}
132.
133*STDOUT = *STDOUT8{FORMAT};
134write;
135
136sub _13 {
137    my $x;
138format STDOUT13 =
139@* - formats closing over redefined subs (got @*)
140ref \$x eq 'SCALAR' ? "ok 13" : "not ok 13", ref \$x;
141.
142}
143undef &_13;
144eval 'sub _13 { my @x; write }';
145*STDOUT = *STDOUT13{FORMAT};
146_13();
147
148# This is a variation of bug #22977, which crashes or fails an assertion
149# up to 5.16.
150# Keep this test last if you want test numbers to be sane.
151BEGIN { \&END }
152END {
153  my $test = "ok 14";
154  *STDOUT = *STDOUT5{FORMAT};
155  write;
156  format STDOUT5 =
157@<<<<<<<
158$test
159.
160}
161