This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Let attributes.pm know about the const attribute
authorFather Chrysostomos <sprout@cpan.org>
Mon, 19 Jan 2015 06:40:09 +0000 (22:40 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 20 Jan 2015 04:34:05 +0000 (20:34 -0800)
Setting it has no affect except on closure prototypes, so warn if an
attempt is made to set it on any other sub.

ext/attributes/attributes.pm
ext/attributes/attributes.xs
pod/perldiag.pod
t/op/attrs.t

index dfd3a25..bac3d7b 100644 (file)
@@ -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
index 6b36812..7ba4f12 100644 (file)
@@ -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':
index cc46a85..c9e49b6 100644 (file)
@@ -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
index 2761d47..f8515fb 100644 (file)
@@ -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();