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
|
#!/usr/bin/perl
# run perlcritic test suite
# needless to say, 'perlcritic' command must be installed
# author: Phil M Perry
# adapted from PDF::Builder tool suite
use strict;
use warnings;
our $VERSION = '1.003'; # VERSION
our $LAST_UPDATE = '1.002'; # manually update whenever code is changed
# command line:
# -5 run perlcritic -5 . (should be clean)
# -5x exclude certain common errors (none at this time)
# -4 run perlcritic -4 . should get a number of common errors
# -4x exclude certain common errors DEFAULT
# -3 run perlcritic -3 . should get a number of errors
# -3x exclude certain common errors
# -2 run perlcritic -2 . should get more errors
# -2x exclude certain common errors
# -1 run perlcritic -1 . should get even more errors
# -1x exclude certain common errors
#
# levels 1,2,3 are only for the morbidly curious!
# (although some warnings look like they should be addressed)
# output <source name> OK is always ignored
my @ignore_list = (
# should not ignore any level 5 warnings
"Use IO::Interactive::is_interactive",
# not a core module!
# common level 4 warnings to ignore
# removed 'no warnings' in 3.021. remove next line 3.022 or later
# "Code before warnings", # due to use of "no warnings" pragma
# removed 'no warnings' in 3.021. remove next line 3.022 or later
# "Warnings disabled at", # due to use of "no warnings" pragma
"Close filehandles as soon as possible",
# it thinks there is no "close" on an open
# filehandle, due to either too many lines for
# it to buffer, or use of other code to close
"Always unpack ", # Always unpack @_ first at line
# not using @_ or $_[n] directly is good practice,
# but it doesn't seem to recognize legitimate uses
"Subroutine name is a homonym for builtin function",
# e.g., we define "open" when there is already a
# system (CORE::) open (ambiguous unless CORE::
# added)
"Symbols are exported by default",
# it doesn't like something about our use of
# @EXPORT and @EXPORT_OK
"Pragma \"constant\" used at", # will have to investigate why "use constant"
# is flagged. TBD
# common level 3 warnings to ignore for now
'"die" used instead of "croak"', #
'"warn" used instead of "carp"', #
'Regular expression without "/x" flag', #
"Backtick operator used", #
"high complexity score", #
"Cascading if-elsif chain", #
"Hard tabs used at", #
'"local" variable not initialized', #
);
# Note that level 4 includes any level 5 errors, etc.
#
my $level;
my @exclude; # leave empty unless "x" suffix
# one command line arg allowed (-4x is default)
if (scalar @ARGV == 0) {
$level = '-4';
@exclude = @ignore_list;
} elsif (scalar @ARGV == 1) {
if ($ARGV[0] eq '-5') {
$level = '-5';
} elsif ($ARGV[0] eq '-5x') {
$level = '-5';
@exclude = @ignore_list;
} elsif ($ARGV[0] eq '-4') {
$level = '-4';
} elsif ($ARGV[0] eq '-4x') {
# default
$level = '-4';
@exclude = @ignore_list;
} elsif ($ARGV[0] eq '-3') {
$level = '-3';
} elsif ($ARGV[0] eq '-3x') {
$level = '-3';
@exclude = @ignore_list;
} elsif ($ARGV[0] eq '-2') {
$level = '-2';
} elsif ($ARGV[0] eq '-2x') {
$level = '-3';
@exclude = @ignore_list;
} elsif ($ARGV[0] eq '-1') {
$level = '-1';
} elsif ($ARGV[0] eq '-1x') {
$level = '-1';
@exclude = @ignore_list;
} else {
die "Unknown command line argument '$ARGV[0]'\n";
}
} else {
die "0 or 1 argument permitted. -4 is default.\n";
}
print STDERR "Calling perlcritic $level";
if (scalar @exclude > 0) { print STDERR ", with excluded warning list"; }
print STDERR ". This can take several minutes to run!\n";
my @results = `perlcritic $level .`;
# always remove " source OK"
my @results2 = ();
foreach my $line (@results) {
if ($line !~ m/ source OK/) {
push @results2, $line;
}
}
if (scalar @exclude > 0 && scalar @results2 > 0) {
@results = @results2;
@results2 = ();
# remove common errors
foreach my $line (@results) {
my $keep = 1;
foreach (@exclude) {
if ($line =~ m/$_/) {
$keep = 0;
last;
}
}
if ($keep) {
push @results2, $line;
}
}
}
if (scalar(@results2) == 0) {
print STDERR "No errors reported.\n";
} else {
print STDERR scalar(@results2)." errors reported:\n";
print "@results2";
}
|
