diff options
| -rw-r--r-- | ext/attributes/attributes.pm | 12 | ||||
| -rw-r--r-- | ext/attributes/attributes.xs | 14 | ||||
| -rw-r--r-- | pod/perldiag.pod | 7 | ||||
| -rw-r--r-- | t/op/attrs.t | 24 |
4 files changed, 53 insertions, 4 deletions
diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm index dfd3a2594c..bac3d7be99 100644 --- 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 6b36812b13..7ba4f12613 100644 --- 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 cc46a85d27..c9e49b6260 100644 --- 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 2761d4747a..f8515fb3d0 100644 --- 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(); |