[perl #107366] Allow attributes to set :lvalue on defined sub

This provides enough rope for those who want to hang themselves, and
also for those who know how to use the rope without hanging them-
selves. :-)

Since this is not generally a reliable thing to be doing, a warning is emitted whenever :lvalue is turned on or off on a defined subroutine.

But attributes.pm will flip the flag anyway.  :lvalue in a sub declar-
ation still refuses to modify a defined Perl sub, as before.

4 files changed, 31 insertions, 24 deletions

diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm
index 4d27f4ff25..2ce7d8771f 100644
--- a/ext/attributes/attributes.pm
+++ b/ext/attributes/attributes.pm
@@ -39,8 +39,8 @@ sub _modify_attrs_and_deprecate {
 	    warnings::warnif(
 		'misc',
 		"lvalue attribute "
-		   . (/^-/ ? "cannot be removed" : "ignored")
-		   . " after the subroutine has been defined"
+		   . (/^-/ ? "removed from" : "applied to")
+		   . " already-defined subroutine"
 	    );
 	    0;
 	} : 1
diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs
index d771889f54..e92f793d5c 100644
--- a/ext/attributes/attributes.xs
+++ b/ext/attributes/attributes.xs
@@ -48,14 +48,15 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
 		switch (name[3]) {
 		case 'l':
 		    if (memEQ(name, "lvalue", 6)) {
-			if (!CvISXSUB(MUTABLE_CV(sv))
+			bool warn =
+			    !CvISXSUB(MUTABLE_CV(sv))
 			 && CvROOT(MUTABLE_CV(sv))
-			 && !CvLVALUE(MUTABLE_CV(sv)) != negated)
-			    break;
+			 && !CvLVALUE(MUTABLE_CV(sv)) != negated;
 			if (negated)
 			    CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
 			else
 			    CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
+			if (warn) break;
 			continue;
 		    }
 		    break;
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 1b67ccde28..5f6ed837f1 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2627,18 +2627,24 @@ You may wish to switch to using L<Math::BigInt> explicitly.
 by that?  lstat() makes sense only on filenames.  (Perl did a fstat()
 instead on the filehandle.)
 
-=item lvalue attribute cannot be removed after the subroutine has been defined
+=item lvalue attribute %s already-defined subroutine
 
-(W misc) The lvalue attribute on a Perl subroutine cannot be turned off
-once the subroutine is defined.
+(W misc) Although L<attributes.pm|attributes> allows this, turning the lvalue
+attribute on or off on a Perl subroutine that is already defined
+does not always work properly.  It may or may not do what you
+want, depending on what code is inside the subroutine, with exact
+details subject to change between Perl versions.  Only do this
+if you really know what you are doing.
 
 =item lvalue attribute ignored after the subroutine has been defined
 
-(W misc) Making a Perl subroutine an lvalue subroutine after it has been
-defined, whether by declaring the subroutine with an lvalue attribute
-or by using L<attributes.pm|attributes>, is not possible.  To make the subroutine an
-lvalue subroutine, add the lvalue attribute to the definition, or put
-the declaration before the definition.
+(W misc) Using the C<:lvalue> declarative syntax to make a Perl
+subroutine an lvalue subroutine after it has been defined is
+not permitted.  To make the subroutine an lvalue subroutine,
+add the lvalue attribute to the definition, or put the C<sub
+foo :lvalue;> declaration before the definition.
+
+See also L<attributes.pm|attributes>.
 
 =item Malformed integer in [] in pack
 
diff --git a/t/op/attrs.t b/t/op/attrs.t
index f3d1165e60..79ef3614fb 100644
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -341,28 +341,28 @@ foreach my $test (@tests) {
   sub  ent         {}
   sub lent :lvalue {}
   my $posmsg =
-      'lvalue attribute ignored after the subroutine has been defined at '
+      'lvalue attribute applied to already-defined subroutine at '
      .'\(eval';
   my $negmsg =
-      'lvalue attribute cannot be removed after the subroutine has been '
-     .'defined at \(eval';
+      'lvalue attribute removed from already-defined subroutine at '
+     .'\(eval';
   eval 'use attributes __PACKAGE__, \&ent, "lvalue"';
   like $w, qr/^$posmsg/, 'lvalue attr warning on def sub';
-  is join("",&attributes::get(\&ent)), "",'lvalue attr ignored on def sub';
+  is join("",&attributes::get(\&ent)), "lvalue",':lvalue applied anyway';
   $w = '';
   eval 'use attributes __PACKAGE__, \&lent, "lvalue"; 1' or die;
   is $w, "", 'no lvalue warning on def lvalue sub';
   eval 'use attributes __PACKAGE__, \&lent, "-lvalue"';
-  like $w, qr/^$negmsg/, 'lvalue attr warning on def sub';
-  is join("",&attributes::get(\&lent)), "lvalue",
-       '-lvalue ignored on def sub';
+  like $w, qr/^$negmsg/, '-lvalue attr warning on def sub';
+  is join("",&attributes::get(\&lent)), "",
+       'lvalue attribute removed anyway';
   $w = '';
-  eval 'use attributes __PACKAGE__, \&ent, "-lvalue"; 1' or die;
-  is $w, "", 'no lvalue warning on def lvalue sub';
+  eval 'use attributes __PACKAGE__, \&lent, "-lvalue"; 1' or die;
+  is $w, "", 'no -lvalue warning on def non-lvalue sub';
   no warnings 'misc';
-  eval 'use attributes __PACKAGE__, \&ent, "lvalue"';
+  eval 'use attributes __PACKAGE__, \&lent, "lvalue"';
   is $w, "", 'no lvalue warnings under no warnings misc';
-  eval 'use attributes __PACKAGE__, \&lent, "-lvalue"';
+  eval 'use attributes __PACKAGE__, \&ent, "-lvalue"';
   is $w, "", 'no -lvalue warnings under no warnings misc';
 }