t/comp/form_scope.t

   1 #!./perl
   2
   3 print "1..14\n";
   4
   5 # Tests bug #22977.  Test case from Dave Mitchell.
   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);
  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
  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 }
  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);
 100
 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
 121 format STDOUT7 =
 122 @<<<<<<<<<<<<<<<<<<<<<<<<<<<
 123 do { my $x = "ok 10 - closure inside format"; sub { $x }->() }
 124 .
 125 *STDOUT = *STDOUT7{FORMAT};
 126 write;
 127
 128 $testn = 12;
 129 format STDOUT8 =
 130 @<<<< - recursive formats
 131 do { my $t = "ok " . $testn--; write if $t =~ 12; $t}
 132 .
 133 *STDOUT = *STDOUT8{FORMAT};
 134 write;
 135
 136 sub _13 {
 137     my $x;
 138 format STDOUT13 =
 139 @* - formats closing over redefined subs (got @*)
 140 ref \$x eq 'SCALAR' ? "ok 13" : "not ok 13", ref \$x;
 141 .
 142 }
 143 undef &_13;
 144 eval '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.
 151 BEGIN { \&END }
 152 END {
 153   my $test = "ok 14";
 154   *STDOUT = *STDOUT5{FORMAT};
 155   write;
 156   format STDOUT5 =
 157 @<<<<<<<
 158 $test
 159 .
 160 }