Cloning a format whose outside has been undefined
authorFather Chrysostomos <sprout@cpan.org>
Sat, 30 Jun 2012 19:43:26 +0000 (12:43 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 30 Jun 2012 21:25:50 +0000 (14:25 -0700)
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.

(cherry-picked from f2ead8b)

pad.c
t/comp/form_scope.t

index 4f0cfb8..c70ca08 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1903,7 +1903,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);
@@ -1934,18 +1934,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;
index ac106e8..d4b5edd 100644 (file)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..5\n";
+print "1..7\n";
 
 # Tests bug #22977.  Test case from Dave Mitchell.
 sub f ($);
@@ -74,3 +74,23 @@ defined $x ? "not ok 4 - $x" : "ok 4"
   print "not " unless $w =~ /^Variable "\$x" is not available at/;
   print "ok 5 - closure var not available when outer sub is inactive\n";
 }
+
+# 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 6 - $z" : "ok 6"
+.
+}
+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 7 - closure var not available when outer sub is undefined\n";
+}