attributes.pm: warn & don’t apply :lvalue to defined subs

This is something that ‘sub foo :lvalue;’ declarations do.  This brings
attributes.pm in line with them.

See commits fff96ff and 885ef6f, ticket #68758, and
<364E1F98-FDCC-49A7-BADB-BD844626B8AE@cpan.org>.

5 files changed, 59 insertions, 6 deletions

diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm
index f79db0fd8c..a7c6716f57 100644
--- a/ext/attributes/attributes.pm
+++ b/ext/attributes/attributes.pm
@@ -34,6 +34,15 @@ sub _modify_attrs_and_deprecate {
 	    require warnings;
 	    warnings::warnif('deprecated', "Attribute \"$1\" is deprecated");
 	    0;
+	} : $svtype eq 'CODE' && /^-?lvalue\z/ ? do {
+	    require warnings;
+	    warnings::warnif(
+		'misc',
+		"lvalue attribute "
+		   . (/^-/ ? "cannot be removed" : "ignored")
+		   . " after the subroutine has been defined"
+	    );
+	    0;
 	} : 1
     } _modify_attrs(@_);
 }
diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs
index 20dc33d187..24f5f6185e 100644
--- a/ext/attributes/attributes.xs
+++ b/ext/attributes/attributes.xs
@@ -48,6 +48,10 @@ 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))
+			 && CvROOT(MUTABLE_CV(sv))
+			 && !CvLVALUE(MUTABLE_CV(sv)) != negated)
+			    break;
 			if (negated)
 			    CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
 			else
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index fbe6682077..10a2d804b9 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -119,7 +119,8 @@ IO::Compress::Zip when the content size was exactly 0xFFFFFFFF.
 
 =item *
 
-L<XXX> has been upgraded from version 0.69 to version 0.70.
+L<attributes> has been upgraded from version 0.14 to 0.15, as part of the
+lvalue attribute warnings fix.  See L</Selected Bug Fixes>, below.
 
 =back
 
@@ -358,6 +359,9 @@ That omission has now been corrected.  C<sub foo :lvalue :Whatever> (when
 C<foo> is already defined) now warns about the :lvalue attribute, and does
 not apply it.
 
+L<attributes.pm|attributes> has likewise been updated to warn and not apply
+the attribute.
+
 =back
 
 =head1 Known Problems
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 7954739f77..51a19e7d1c 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2474,13 +2474,18 @@ 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
+
+(W misc) The lvalue attribute on a Perl subroutine cannot be turned off
+once the subroutine is defined.
+
 =item lvalue attribute ignored after the subroutine has been defined
 
-(W misc) Making a subroutine an lvalue subroutine after it has been defined
-by declaring the subroutine with an lvalue attribute 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) 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.
 
 =item Malformed integer in [] in pack
 
diff --git a/t/op/attrs.t b/t/op/attrs.t
index c0225c7be6..2567fa9082 100644
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -332,4 +332,35 @@ foreach my $test (@tests) {
   ::is "@go", 'jabber joo', 'list assignment to array with attrs';
 }
 
+{
+  my $w;
+  local $SIG{__WARN__} = sub { $w = shift };
+  sub  ent         {}
+  sub lent :lvalue {}
+  my $posmsg =
+      'lvalue attribute ignored after the subroutine has been defined at '
+     .'\(eval';
+  my $negmsg =
+      'lvalue attribute cannot be removed after the subroutine has been '
+     .'defined 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';
+  $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';
+  $w = '';
+  eval 'use attributes __PACKAGE__, \&ent, "-lvalue"; 1' or die;
+  is $w, "", 'no lvalue warning on def lvalue sub';
+  no warnings 'misc';
+  eval 'use attributes __PACKAGE__, \&ent, "lvalue"';
+  is $w, "", 'no lvalue warnings under no warnings misc';
+  eval 'use attributes __PACKAGE__, \&lent, "-lvalue"';
+  is $w, "", 'no -lvalue warnings under no warnings misc';
+}
+
 done_testing();