Cloning a format whose outside has been undefined

This has crashed ever since 71f882da8, because the format tries to
close over a pad that does not exist:

sub x {
    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
    my $z;
    format =
@<<<
$z
.
}
undef &x;
write;

This commit adds checks for nonexistent pads, producing the ‘Variable
is not available’ warning in cases like this.

diff --git a/pad.c b/pad.c
index c569e18..032f8f5 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1946,7 +1946,7 @@ Perl_cv_clone(pTHX_ CV *proto)
     assert(depth || SvTYPE(proto) == SVt_PVFM);
     if (!depth)
        depth = 1;
-    assert(CvPADLIST(outside));
+    assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);
 
     ENTER;
     SAVESPTR(PL_compcv);
@@ -1981,18 +1981,20 @@ Perl_cv_clone(pTHX_ CV *proto)
 
     PL_curpad = AvARRAY(PL_comppad);
 
-    outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
+    outpad = CvPADLIST(outside)
+       ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
+       : NULL;
 
     for (ix = fpad; ix > 0; ix--) {
        SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
        SV *sv = NULL;
        if (namesv && namesv != &PL_sv_undef) { /* lexical */
            if (SvFAKE(namesv)) {   /* lexical from outside? */
-               sv = outpad[PARENT_PAD_INDEX(namesv)];
-               /* formats may have an inactive parent,
+               /* formats may have an inactive, or even undefined, parent,
                   while my $x if $false can leave an active var marked as
                   stale. And state vars are always available */
-               if (!sv || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
+               if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
+                || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
                    Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
                                   "Variable \"%"SVf"\" is not available", namesv);
                    sv = NULL;

diff --git a/t/comp/form_scope.t b/t/comp/form_scope.t
index 6344652..809e0d2 100644 (file)
--- a/t/comp/form_scope.t
+++ b/t/comp/form_scope.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..8\n";
+print "1..10\n";
 
 # Tests bug #22977.  Test case from Dave Mitchell.
 sub f ($);
@@ -98,12 +98,32 @@ $next = $clo1;
 $next = $clo2;
 &$clo1(0);
 
+# Cloning a format whose outside has been undefined
+sub x {
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    my $z;
+    format STDOUT6 =
+@<<<<<<<<<<<<<<<<<<<<<<<<<
+defined $z ? "not ok 8 - $z" : "ok 8"
+.
+}
+undef &x;
+*STDOUT = *STDOUT6{FORMAT};
+{
+  local $^W = 1;
+  my $w;
+  local $SIG{__WARN__} = sub { $w = shift };
+  write;
+  print "not " unless $w =~ /^Variable "\$z" is not available at/;
+  print "ok 9 - closure var not available when outer sub is undefined\n";
+}
+
 # This is a variation of bug #22977, which crashes or fails an assertion
 # up to 5.16.
 # Keep this test last if you want test numbers to be sane.
 BEGIN { \&END }
 END {
-  my $test = "ok 8";
+  my $test = "ok 10";
   *STDOUT = *STDOUT5{FORMAT};
   write;
   format STDOUT5 =