Let attributes.pm know about the const attribute

Setting it has no affect except on closure prototypes, so warn if an
attempt is made to set it on any other sub.

diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm
index dfd3a25..bac3d7b 100644 (file)
--- a/ext/attributes/attributes.pm
+++ b/ext/attributes/attributes.pm
@@ -23,6 +23,12 @@ $deprecated{CODE} = qr/\A-?(locked)\z/;
 $deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR}
     = qr/\A-?(unique)\z/;
 
+my %msg = (
+    lvalue => 'lvalue attribute applied to already-defined subroutine',
+   -lvalue => 'lvalue attribute removed from already-defined subroutine',
+    const  => 'Useless use of attribute "const"',
+);
+
 sub _modify_attrs_and_deprecate {
     my $svtype = shift;
     # Now that we've removed handling of locked from the XS code, we need to
@@ -34,13 +40,11 @@ sub _modify_attrs_and_deprecate {
            require warnings;
            warnings::warnif('deprecated', "Attribute \"$1\" is deprecated");
            0;
-       } : $svtype eq 'CODE' && /^-?lvalue\z/ ? do {
+       } : $svtype eq 'CODE' && exists $msg{$_} ? do {
            require warnings;
            warnings::warnif(
                'misc',
-               "lvalue attribute "
-                  . (/^-/ ? "removed from" : "applied to")
-                  . " already-defined subroutine"
+                $msg{$_}
            );
            0;
        } : 1

diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs
index 6b36812..7ba4f12 100644 (file)
--- a/ext/attributes/attributes.xs
+++ b/ext/attributes/attributes.xs
@@ -44,6 +44,20 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
        switch (SvTYPE(sv)) {
        case SVt_PVCV:
            switch ((int)len) {
+           case 5:
+               if (memEQ(name, "const", 5)) {
+                   if (negated)
+                       CvANONCONST_off(sv);
+                   else {
+                       const bool warn = (!CvCLONE(sv) || CvCLONED(sv))
+                                      && !CvANONCONST(sv);
+                       CvANONCONST_on(sv);
+                       if (warn)
+                           break;
+                   }
+                   continue;
+               }
+               break;
            case 6:
                switch (name[3]) {
                case 'l':

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index cc46a85..c9e49b6 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -6440,6 +6440,13 @@ must be written as
 The <-- HERE shows whereabouts in the regular expression the problem was
 discovered.  See L<perlre>.
 
+=item Useless use of attribute "const"
+
+(W misc) The "const" attribute has no effect except
+on anonymous closure prototypes.  You applied it to
+a subroutine via L<attributes.pm|attributes>.  This is only useful
+inside an attribute handler for an anonymous subroutine.
+
 =item Useless use of /d modifier in transliteration operator
 
 (W misc) You have used the /d modifier where the searchlist has the

diff --git a/t/op/attrs.t b/t/op/attrs.t
index 2761d47..f8515fb 100644 (file)
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -389,4 +389,28 @@ package ProtoTest {
 }
 is $ProtoTest::Proto, '$', 'prototypes are visible in attr handlers';
 
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w = shift };
+    attributes ->import(__PACKAGE__, \&foo, "const");
+    like $w, qr/^Useless use of attribute "const" at /,
+            'Warning for useless const via attributes.pm';
+    $w = '';
+    attributes ->import(__PACKAGE__, \&foo, "const");
+    is $w, '', 'no warning for const if already applied';
+    attributes ->import(__PACKAGE__, \&foo, "-const");
+    is $w, '', 'no warning for -const with attr already applied';
+    attributes ->import(__PACKAGE__, \&bar, "-const");
+    is $w, '', 'no warning for -const with attr not already applied';
+    package ConstTest;
+    sub MODIFY_CODE_ATTRIBUTES {
+        attributes->import(shift, shift, lc shift) if $_[2]; ()
+    }
+    $_ = 32487;
+    my $sub = sub : Const { $_ };
+    undef $_;
+    ::is &$sub, 32487,
+        'applying const attr via attributes.pm';
+}
+
 done_testing();