From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

ELLIOTJS / Perl-Critic-1.099_002 / lib / Perl / Critic / Policy / TestingAndDebugging / ProhibitNoStrict.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
—
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157

              
##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm $
#     $Date: 2009-06-27 20:02:58 -0400 (Sat, 27 Jun 2009) $
#   $Author: clonezone $
# $Revision: 3373 $
##############################################################################
package Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict;
use 5.006001;
use strict;
use warnings;
use Readonly;
use List::MoreUtils qw(all);
use Perl::Critic::Utils qw{ :characters :severities :data_conversion };
use base 'Perl::Critic::Policy';
our $VERSION = '1.099_002';
#-----------------------------------------------------------------------------
Readonly::Scalar my $DESC => q{Stricture disabled};
Readonly::Scalar my $EXPL => [ 429 ];
#-----------------------------------------------------------------------------
sub supported_parameters {
    return (
        {
            name            => 'allow',
            description     => 'Allow vars, subs, and/or refs.',
            default_string  => $EMPTY,
            parser          => \&_parse_allow,
        },
    );
}
sub default_severity { return $SEVERITY_HIGHEST         }
sub default_themes   { return qw( core pbp bugs )       }
sub applies_to       { return 'PPI::Statement::Include' }
#-----------------------------------------------------------------------------
sub _parse_allow {
    my ($self, $parameter, $config_string) = @_;
    $self->{_allow} = {};
    if( defined $config_string ) {
        my $allowed = lc $config_string; #String of words
        my %allowed = hashify( $allowed =~ m/ (\w+) /gxms );
        $self->{_allow} = \%allowed;
    }
    return;
}
#-----------------------------------------------------------------------------
sub violates {
    my ( $self, $elem, undef ) = @_;
    return if $elem->type()   ne 'no';
    return if $elem->pragma() ne 'strict';
    #Arguments to 'no strict' are usually a list of literals or a qw()
    #list.  Rather than trying to parse the various PPI elements, I
    #just use a regex to split the statement into words.  This is
    #kinda lame, but it does the trick for now.
    # TODO consider: a possible alternate implementation:
    #   my $re = join q{|}, keys %{$self->{allow}};
    #   return if $re && $stmnt =~ m/\b(?:$re)\b/mx;
    # May need to detaint for that to work...  Not sure.
    my $stmnt = $elem->statement();
    return if !$stmnt;
    my @words = $stmnt =~ m/ ([[:lower:]]+) /gxms;
    @words = grep { $_ ne 'qw' && $_ ne 'no' && $_ ne 'strict' } @words;
    return if all { exists $self->{_allow}->{$_} } @words;
    #If we get here, then it must be a violation
    return $self->violation( $DESC, $EXPL, $elem );
}
1;
__END__
#-----------------------------------------------------------------------------
=pod
=head1 NAME
Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict - Prohibit various flavors of C<no strict>.
=head1 AFFILIATION
This Policy is part of the core L<Perl::Critic|Perl::Critic>
distribution.
=head1 DESCRIPTION
There are good reasons for disabling certain kinds of strictures, But
if you were wise enough to C<use strict> in the first place, then it
doesn't make sense to disable it completely.  By default, any C<no
strict> statement will violate this policy.  However, you can
configure this Policy to allow certain types of strictures to be
disabled (See L</CONFIGURATION>).  A bare C<no strict> statement will
always raise a violation.
=head1 CONFIGURATION
The permitted strictures can be configured via the C<allow> option.
The value is a list of whitespace-delimited stricture types that you
want to permit.  These can be C<vars>, C<subs> and/or C<refs>.  An
example of this customization:
    [TestingAndDebugging::ProhibitNoStrict]
    allow = vars subs refs
=head1 SEE ALSO
L<Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict|Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict>
=head1 AUTHOR
Jeffrey Ryan Thalhammer <thaljef@cpan.org>
=head1 COPYRIGHT
Copyright (c) 2005-2009 Jeffrey Ryan Thalhammer.  All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  The full text of this license
can be found in the LICENSE file included with this module
=cut
##############################################################################
# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 78
#   indent-tabs-mode: nil
#   c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :