Deprecate using "locked" with the attributes pragma.

diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm
index 701ff1b..ac5ef09 100644 (file)
--- a/ext/attributes/attributes.pm
+++ b/ext/attributes/attributes.pm
@@ -1,6 +1,6 @@
 package attributes;
 
-our $VERSION = 0.11;
+our $VERSION = 0.12;
 
 @EXPORT_OK = qw(get reftype);
 @EXPORT = ();
@@ -18,6 +18,21 @@ sub carp {
     goto &Carp::carp;
 }
 
+sub _modify_attrs_and_deprecate {
+    my $svtype = shift;
+    # Now that we've removed handling of locked from the XS code, we need to
+    # remove it here, else it ends up in @badattrs. (If we do the deprecation in
+    # XS, we can't control the warning based on *our* caller's lexical settings,
+    # and the warned line is in this package)
+    grep {
+       $svtype eq 'CODE' && /\A-?locked\z/ ? do {
+           require warnings;
+           warnings::warnif('deprecated', 'Attribute "locked" is deprecated');
+           0;
+       } : 1
+    } _modify_attrs(@_);
+}
+
 sub import {
     @_ > 2 && ref $_[2] or do {
        require Exporter;
@@ -31,7 +46,7 @@ sub import {
        if defined $home_stash && $home_stash ne '';
     my @badattrs;
     if ($pkgmeth) {
-       my @pkgattrs = _modify_attrs($svref, @attrs);
+       my @pkgattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
        @badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs);
        if (!@badattrs && @pkgattrs) {
             require warnings;
@@ -49,7 +64,7 @@ sub import {
        }
     }
     else {
-       @badattrs = _modify_attrs($svref, @attrs);
+       @badattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
     }
     if (@badattrs) {
        croak "Invalid $svtype attribute" .

diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs
index 35ded7b..dceef68 100644 (file)
--- a/ext/attributes/attributes.xs
+++ b/ext/attributes/attributes.xs
@@ -54,15 +54,6 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
                        continue;
                    }
                    break;
-               case 'k':
-                   if (memEQ(name, "locked", 6)) {
-                       if (negated)
-                           CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LOCKED;
-                       else
-                           CvFLAGS(MUTABLE_CV(sv)) |= CVf_LOCKED;
-                       continue;
-                   }
-                   break;
                case 'h':
                    if (memEQ(name, "method", 6)) {
                        if (negated)

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 6170560..746c3b9 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -306,6 +306,13 @@ of an array and later assigning through that reference. For example
 used as an lvalue, which is pretty strange.  Perhaps you forgot to
 dereference it first.  See L<perlfunc/substr>.
 
+=item Attribute "locked" is deprecated
+
+(D deprecated) You have used the attributes pragam to modify the "locked"
+attribute on a code reference. The :locked attribute is obsolete, has had no
+effect since 5005 threads were removed, and will be removed in the next major
+release of Perl 5.
+
 =item Bad arg length for %s, is %d, should be %s
 
 (F) You passed a buffer of the wrong size to one of msgctl(), semctl()

diff --git a/t/op/attrs.t b/t/op/attrs.t
index bf1ed84..f124e8d 100644 (file)
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -148,21 +148,27 @@ eval 'my $$foo : bar = 1';
 like $@, qr/Can't declare scalar dereference in "my"/;
 
 
-my @code = qw(lvalue locked method);
+my @code = qw(lvalue method);
 my @other = qw(shared unique);
+my @deprecated = qw(locked);
 my %valid;
 $valid{CODE} = {map {$_ => 1} @code};
 $valid{SCALAR} = {map {$_ => 1} @other};
 $valid{ARRAY} = $valid{HASH} = $valid{SCALAR};
+my %deprecated;
+$deprecated{CODE} = { locked => 1 };
 
 our ($scalar, @array, %hash);
 foreach my $value (\&foo, \$scalar, \@array, \%hash) {
     my $type = ref $value;
     foreach my $negate ('', '-') {
-       foreach my $attr (@code, @other) {
+       foreach my $attr (@code, @other, @deprecated) {
            my $attribute = $negate . $attr;
            eval "use attributes __PACKAGE__, \$value, '$attribute'";
-           if ($valid{$type}{$attr}) {
+           if ($deprecated{$type}{$attr}) {
+               like $@, qr/^Attribute "$attr" is deprecated at \(eval \d+\)/,
+                   "$type attribute $attribute deprecated";
+           } elsif ($valid{$type}{$attr}) {
                if ($attribute eq '-shared') {
                    like $@, qr/^A variable may not be unshared/;
                } else {