$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
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
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':
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
}
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();