From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 12 Apr 2009 14:50:16 +0000 (+0100)
Subject: Deprecate using "locked" with the attributes pragma.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c32124fea7b8ddab6f359599ed11fec4ff102451;p=p5sagit%2Fp5-mst-13.2.git

Deprecate using "locked" with the attributes pragma.
---

diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm
index 701ff1b..ac5ef09 100644
--- 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
--- 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
--- 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
--- 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 {