Fix subroutine unavailability during cloning

sub foo {
  my $x;
  format =
@
$x||'#'
.
}
write;
__END__
Variable "$x" is not available at - line 9.

That one’s OK.

sub foo {
  my sub x {};
  format =
@
&x
.
}
write;
__END__
Variable "&x" is not available at - line 9.
Assertion failed: (SvTYPE(_svmagic) >= SVt_PVMG), function S_mg_findext_flags, file mg.c, line 404.
Abort trap

That should say ‘Subroutine’.  And it shouldn’t crash.

The my-sub-cloning code was not taking this case into account.  The
value in the proto pad is an undef scalar.

diff --git a/pad.c b/pad.c
index 195e737..03cb555 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -2044,8 +2044,13 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
                if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
                 || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
                    && (!outside || !CvDEPTH(outside)))  ) {
+                   /* diag_listed_as: Variable "%s" is not available */
                    Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
-                                  "Variable \"%"SVf"\" is not available", namesv);
+                                  "%se \"%"SVf"\" is not available",
+                                  SvPVX_const(namesv)[0] == '&'
+                                       ? "Subroutin"
+                                       : "Variabl",
+                                  namesv);
                    sv = NULL;
                }
                else 
@@ -2069,6 +2074,8 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
                    else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
                    {
                        /* my sub */
+                     sv = newSV_type(SVt_PVCV);
+                     if (SvTYPE(ppad[ix]) == SVt_PVCV) {
                        /* This is actually a stub with a proto CV attached
                           to it by magic.  Since the stub itself is used
                           when the proto is cloned, we need a new stub
@@ -2080,10 +2087,21 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
                        assert(mg->mg_obj);
                        assert(SvTYPE(ppad[ix]) == SVt_PVCV);
                        assert(CvNAME_HEK((CV *)ppad[ix]));
-                       sv = newSV_type(SVt_PVCV);
                        CvNAME_HEK_set(sv,
                            share_hek_hek(CvNAME_HEK((CV *)ppad[ix])));
                        sv_magic(sv,mg->mg_obj,PERL_MAGIC_proto,NULL,0);
+                     }
+                     else {
+                       assert(SvTYPE(ppad[ix]) == SVt_NULL);
+                       /* Unavailable; just provide a stub, but name it */
+                       CvNAME_HEK_set(
+                           sv,
+                           share_hek(SvPVX_const(namesv)+1,
+                                     SvCUR(namesv) - 1
+                                        * (SvUTF8(namesv) ? -1 : 1),
+                                     0)
+                       );
+                     }
                    }
                    else sv = SvREFCNT_inc(ppad[ix]);
                 else if (sigil == '@')

diff --git a/t/cmd/lexsub.t b/t/cmd/lexsub.t
index c3934ba..7f6df17 100644 (file)
--- a/t/cmd/lexsub.t
+++ b/t/cmd/lexsub.t
@@ -8,7 +8,7 @@ BEGIN {
     *bar::like = *like;
 }
 no warnings 'deprecated';
-plan 115;
+plan 117;
 
 # -------------------- our -------------------- #
 
@@ -511,6 +511,22 @@ sub make_anon_with_my_sub{
 ->()();
   is $w, "Subroutine \"&x\" is not available at khaki line 90.\n",
          "unavailability warning during compilation of named sub in anon";
+
+  undef $w;
+  sub not_lexical9 {
+    my sub x {};
+    format =
+@
+&x
+.
+  }
+  eval { write };
+  my($f,$l) = (__FILE__,__LINE__ - 1);
+  is $w, "Subroutine \"&x\" is not available at $f line $l.\n",
+         'unavailability warning during cloning';
+  $l -= 3;
+  is $@, "Undefined subroutine &x called at $f line $l.\n",
+         'Vivified sub is correctly named';
 }
 
 # -------------------- Interactions (and misc tests) -------------------- #