[perl #68560] calling closure prototype SEGVs

When a closure is created, the original sub is cloned (except that the
op tree is shared). That original sub (called the closure prototype)
is not usually accessible to perl.

An attribute handler (MODIFY_CODE_ATTRIBUTES) is passed a reference
to it, however. If that code reference is called within the attribute
handler, an ‘Undefined subroutine called’ error results, because the
op tree has not been attached yet.

If that code reference is stashed away and called after the attribute
handler returns, it will most likely crash.

This is because its pad is full of nulls.

A regular $proto->() or &$proto() call that sets up @_ will crash in
attempting to do so.

A &$proto call will bypass that, but attempting to read any lexical
variables from the containing scope will cause a crash. Any operator
that uses TARG (i.e., most of them) will crash.

So this commit puts a check for closure prototypes in pp_entersub. It
produces a new error message, ‘Closure prototype called’.

This does introduce a backward-incompatible change: code like this
used to work:

 sub MODIFY_CODE_ATTRIBUTES { $'proto = $_[1] }
 { my $x; () = sub :attr { () = $x; print "hello\n" } }
 &$'proto;

But writing a useful subroutine that tiptoes past the crashes is so
difficult that I think this breakage is acceptable.

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 7250057..b099633 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1347,6 +1347,12 @@ uses the character values modulus 256 instead, as if you had provided:
 (W io) The dirhandle you tried to close is either closed or not really
 a dirhandle.  Check your control flow.
 
+=item Closure prototype called
+
+(F) If a closure has attributes, the subroutine passed to an attribute
+handler is the prototype that is cloned when a new closure is created.
+This subroutine cannot be called.
+
 =item Code missing after '/'
 
 (F) You had a (sub-)template that ends with a '/'. There must be another

diff --git a/pp_hot.c b/pp_hot.c
index 8c9c915..2176bac 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -297,6 +297,7 @@ PP(pp_concat)
 PP(pp_padsv)
 {
     dVAR; dSP; dTARGET;
+    if(!TARG) TARG = PAD_SVl(PL_op->op_targ) = newSV(0);
     XPUSHs(TARG);
     if (PL_op->op_flags & OPf_MOD) {
        if (PL_op->op_private & OPpLVAL_INTRO)
@@ -2825,6 +2826,8 @@ PP(pp_entersub)
     SAVETMPS;
 
   retry:
+    if (CvCLONE(cv) && ! CvCLONED(cv))
+       DIE(aTHX_ "Closure prototype called");
     if (!CvROOT(cv) && !CvXSUB(cv)) {
        GV* autogv;
        SV* sub_name;
@@ -2896,7 +2899,9 @@ try_autoload:
        SAVECOMPPAD();
        PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
        if (hasargs) {
-           AV *const av = MUTABLE_AV(PAD_SVl(0));
+           AV *av = MUTABLE_AV(PAD_SVl(0));
+           if ((SV *)av == &PL_sv_undef)
+               PAD_SVl(0) = (SV *)(av = newAV());
            if (AvREAL(av)) {
                /* @_ is normally not REAL--this should only ever
                 * happen when DB::sub() calls things that modify @_ */

diff --git a/t/op/attrs.t b/t/op/attrs.t
index 4e1a4c3..b7809a8 100644 (file)
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -295,4 +295,22 @@ foreach my $test (@tests) {
     }
 }
 
+# [perl #68560] Calling closure prototypes (only accessible via :attr)
+{
+  package brength;
+  my $proto;
+  sub MODIFY_CODE_ATTRIBUTES { $proto = $_[1]; _: }
+  {
+     my $x;
+     () = sub :a0 { $x };
+  }
+  package main;
+  eval { $proto->() };               # used to crash in pp_entersub
+  like $@, qr/^Closure prototype called/,
+     "Calling closure proto with (no) args";
+  eval { () = &$proto };             # used to crash in pp_leavesub
+  like $@, qr/^Closure prototype called/,
+     "Calling closure proto with no @_ that returns a lexical";
+}
+
 done_testing();