Re: perl 5.7.3 + XS lvalue subs

Message-Id: <200203280152.UAA415562@leggy.zk3.dec.com>

p4raw-id: //depot/perl@15565

diff --git a/cv.h b/cv.h
index 824517c..ccbfa43 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -85,6 +85,8 @@ Returns the stash of the CV.
 #define CVf_LOCKED     0x0080  /* CV locks itself or first arg on entry */
 #define CVf_LVALUE     0x0100  /* CV return value can be used as lvalue */
 #define CVf_CONST      0x0200  /* inlinable sub */
+/* This symbol for optimised communication between toke.c and op.c: */
+#define CVf_BUILTIN_ATTRS      (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)
 
 #define CvCLONE(cv)            (CvFLAGS(cv) & CVf_CLONE)
 #define CvCLONE_on(cv)         (CvFLAGS(cv) |= CVf_CLONE)

diff --git a/op.c b/op.c
index 82c9b02..98d42da 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4842,6 +4842,10 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        /* already defined (or promised)? */
        if (exists || GvASSUMECV(gv)) {
            if (!block && !attrs) {
+               if (CvFLAGS(PL_compcv)) {
+                   /* might have had built-in attrs applied */
+                   CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
+               }
                /* just a "sub foo;" when &foo is already defined */
                SAVEFREESV(PL_compcv);
                goto done;

diff --git a/t/op/attrs.t b/t/op/attrs.t
index 611fb66..8e04936 100644 (file)
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -174,6 +174,12 @@ BEGIN {++$ntests}
 mytest '', "@attrs", "locked method Z";
 BEGIN {++$ntests}
 
+# Test ability to modify existing sub's (or XSUB's) attributes.
+eval 'package A; sub X { $_[0] } sub X : lvalue';
+@attrs = eval 'attributes::get \&A::X';
+mytest '', "@attrs", "lvalue";
+BEGIN {++$ntests}
+
 # Begin testing attributes that tie
 
 {

diff --git a/toke.c b/toke.c
index 87c94c1..85ec1d1 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2990,6 +2990,8 @@ Perl_yylex(pTHX)
                    PL_lex_stuff = Nullsv;
                }
                else {
+                   /* NOTE: any CV attrs applied here need to be part of
+                      the CVf_BUILTIN_ATTRS define in cv.h! */
                    if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
                        CvLVALUE_on(PL_compcv);
                    else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
@@ -2997,14 +2999,20 @@ Perl_yylex(pTHX)
                    else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
                        CvMETHOD_on(PL_compcv);
 #ifdef USE_ITHREADS
-      else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
+                   else if (PL_in_my == KEY_our && len == 6 &&
+                            strnEQ(s, "unique", len))
                        GvUNIQUE_on(cGVOPx_gv(yylval.opval));
 #endif
                    /* After we've set the flags, it could be argued that
                       we don't need to do the attributes.pm-based setting
                       process, and shouldn't bother appending recognized
-                      flags. To experiment with that, uncomment the
-                      following "else": */
+                      flags.  To experiment with that, uncomment the
+                      following "else".  (Note that's already been
+                      uncommented.  That keeps the above-applied built-in
+                      attributes from being intercepted (and possibly
+                      rejected) by a package's attribute routines, but is
+                      justified by the performance win for the common case
+                      of applying only built-in attributes.) */
                    else
                        attrs = append_elem(OP_LIST, attrs,
                                            newSVOP(OP_CONST, 0,