develooper Front page | perl.perl5.changes | Postings from November 2010

[perl.git] branch blead, updated. v5.13.7-199-g4d4ca6a

From:
Father Chrysostomos
Date:
November 29, 2010 21:51
Subject:
[perl.git] branch blead, updated. v5.13.7-199-g4d4ca6a
Message ID:
E1PNJ7g-0003gw-P2@camel.ams6.corp.booking.com
In perl.git, the branch blead has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/4d4ca6a56be9d33d931a2fa0cdd3ab836ad49e79?hp=56a86867b86f603e24bea0daab37d0f2a978e03c>

- Log -----------------------------------------------------------------
commit 4d4ca6a56be9d33d931a2fa0cdd3ab836ad49e79
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Mon Nov 29 21:50:59 2010 -0800

    perldelta entry for [perl #68560]

M	pod/perldelta.pod

commit 541ed3a941cdbe4a796e28c53e976cbcbbb3ccb7
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Mon Nov 29 21:43:52 2010 -0800

    [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.

M	pod/perldiag.pod
M	pp_hot.c
M	t/op/attrs.t
-----------------------------------------------------------------------

Summary of changes:
 pod/perldelta.pod |    8 +++++++-
 pod/perldiag.pod  |    6 ++++++
 pp_hot.c          |    7 ++++++-
 t/op/attrs.t      |   18 ++++++++++++++++++
 4 files changed, 37 insertions(+), 2 deletions(-)

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 8c660f7..3d9f5f4 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -283,7 +283,7 @@ XXX Newly added diagnostic messages go here
 
 =item *
 
-XXX
+There is a new "Closure prototype called" error.
 
 =back
 
@@ -477,6 +477,12 @@ A closure containing an C<if> statement followed by a constant or variable
 is no longer treated as a constant
 L<[perl #63540]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=63540>.
 
+=item *
+
+Calling a closure prototype (what is passed to an attribute handler for a
+closure) now results in a "Closure prototype called" error message
+L<[perl #68560]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=68560>.
+
 =back
 
 =head1 Known Problems
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 7250057..b099633 100644
--- 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
--- 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
--- 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();

--
Perl5 Master Repository



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About