Login
Now that we have ProhibitUselessNoCritic, we can
[gknop/Perl-Critic.git] / examples / loadanalysisdb
CommitLineData
81f23a94
ES
1#!/usr/bin/perl
2
3##############################################################################
4# $URL$
5# $Date$
6# $Author$
7# $Revision$
81f23a94
ES
8##############################################################################
9
d5835ca8 10
81f23a94
ES
11use 5.008001;
12use strict;
13use warnings;
14
173667ce 15use version; our $VERSION = qv('1.093_001');
81f23a94
ES
16
17use Carp qw{ croak };
18use English qw{ -no_match_vars };
19use Readonly;
20
21use DBI qw{ :sql_types };
22use File::Spec qw{ };
23use Perl6::Say;
24
25use Perl::Critic::Utils qw{ all_perl_files policy_short_name $EMPTY };
26use Perl::Critic;
27
28
29if ( ! @ARGV ) {
30 die qq{usage: loadanalysisdb path [...]\n};
31}
32
33main();
34
35exit 0;
36
37
38sub main {
39 say 'Connecting to database.';
40 say;
41
42 my $database_connection = connect_to_database();
43 my $insert_statement = prepare_insert_statement($database_connection);
44
45 foreach my $path ( @ARGV ) {
46 say "Looking at $path.";
47
48 my @files = all_perl_files($path);
49 say 'Analyzing ', scalar @files, ' files.';
50
51 load( \@files, File::Spec->canonpath($path), $insert_statement );
52
53 say; say;
54 }
55
56 say 'Disconnecting from database.';
57 say;
58
59 close_insert_statement($insert_statement);
60 # Need to do this or DBI emits warning at disconnect
61 $insert_statement = undef;
62
63 disconnect_from_database($database_connection);
64
65 say 'Done.';
66 say;
67
68 return;
69}
70
71
72sub load {
73 my ( $files, $path, $insert_statement ) = @_;
74
75 # Force reporting level to be really strict, just so that the database
76 # has everything.
77 my $critic = Perl::Critic->new( -severity => 1 );
78
79 foreach my $file ( @{$files} ) {
80 my $relative_path;
81
82 if ($file eq $path) {
83 $relative_path = $file;
84 } else {
85 my $absolute_path_length = ( length $path ) + 1;
86
87 $relative_path = substr $file, $absolute_path_length;
88 }
89
90 say "Processing $relative_path.";
91
92 foreach my $violation ( $critic->critique($file) ) {
93 my ($line, $column) = @{ $violation->location() };
94
95 execute_insert_statement(
96 $insert_statement,
97 $relative_path,
98 $line,
99 $column,
100 $violation->severity(),
101 policy_short_name( $violation->policy() ),
102 $violation->explanation(),
103 $violation->source(),
104 );
105 }
106 }
107
108 return;
109}
110
111
112sub connect_to_database {
113 my $database_file_name = 'perl_critic_analysis.sqlite';
114
115 my $database_connection =
116 DBI->connect(
117 "dbi:SQLite:dbname=$database_file_name",
118 $EMPTY, # login
119 $EMPTY, # password
120 {
121 AutoCommit => 1, # In real life, this should be 0
122 RaiseError => 1,
123 }
124 );
125
126 defined $database_connection or
127 croak "Could not connect to $database_file_name.";
128
129 return $database_connection;
130}
131
132
133sub prepare_insert_statement {
134 my ( $database_connection ) = @_;
135
136 my $insert_statement =
137 $database_connection->prepare(<<'END_SQL');
138 INSERT INTO
139 violation
140 (
141 file_path,
142 line_number,
143 column_number,
144 severity,
145 policy,
146 explanation,
147 source_code
148 )
149 VALUES
150 (?, ?, ?, ?, ?, ?, ?)
151END_SQL
152
153
154 # The following values are bogus-- these statements are simply to tell
155 # the driver what the parameter types are so that we can use execute()
156 # without calling bind_param() each time. See "Binding Values Without
379bd376 157 # bind_param()" on pages 126-7 of "Programming the Perl DBI".
29e94807
ES
158
159 ## no critic (ProhibitMagicNumbers)
81f23a94
ES
160 $insert_statement->bind_param( 1, 'x', SQL_VARCHAR);
161 $insert_statement->bind_param( 2, 1, SQL_INTEGER);
162 $insert_statement->bind_param( 3, 1, SQL_INTEGER);
163 $insert_statement->bind_param( 4, 1, SQL_INTEGER);
164 $insert_statement->bind_param( 5, 'x', SQL_VARCHAR);
165 $insert_statement->bind_param( 6, 'x', SQL_VARCHAR);
29e94807
ES
166 $insert_statement->bind_param( 7, 'x', SQL_VARCHAR);
167 ## use critic
81f23a94
ES
168
169 return $insert_statement;
170}
171
172
c6e19b74 173sub execute_insert_statement { ##no critic(ProhibitManyArgs)
81f23a94
ES
174 my (
175 $statement,
176 $file_path,
177 $line_number,
178 $column_number,
179 $severity,
180 $policy,
181 $explanation,
182 $source_code,
183 )
184 = @_;
185
186 $statement->execute(
187 $file_path,
188 $line_number,
189 $column_number,
190 $severity,
191 $policy,
192 $explanation,
193 $source_code,
194 );
195
196 return;
197}
198
199
200sub close_insert_statement {
201 my ( $insert_statement ) = @_;
202
203 $insert_statement->finish();
204
205 return;
206}
207
208sub disconnect_from_database {
209 my ( $database_connection ) = @_;
210
211 $database_connection->disconnect();
212
213 return;
214}
215
216
217__END__
218
219=pod
220
27fb3a4e 221=for stopwords SQLite DBI analyses perlartistic
ee0fa298 222
81f23a94
ES
223=head1 NAME
224
225C<loadanalysisdb> - Critique a body of code and load the results into a database for later processing.
226
227
228=head1 USAGE
229
11f53956 230 loadanalysisdb path [...]
81f23a94
ES
231
232
233=head1 DESCRIPTION
234
11f53956
ES
235Scan a body of code and, rather than emit the results in a textual
236format, put them into a database so that analyses can be made.
81f23a94 237
11f53956
ES
238This example doesn't put anything into the database that isn't
239available from L<Perl::Critic::Violation|Perl::Critic::Violation> in
240order to keep the code easier to understand. In a full application of
241the idea presented here, one might want to include the current date
242and a distribution name in the database so that progress on cleaning
243up a code corpus can be tracked.
81f23a94 244
11f53956
ES
245Note the explanation attribute of
246L<Perl::Critic::Violation|Perl::Critic::Violation> is constant for
247most policies, but some of them do provide more specific diagnostics
248of the code in question.
81f23a94
ES
249
250
251=head1 REQUIRED ARGUMENTS
252
253A list of paths to files and directories to find code in.
254
255
256=head1 OPTIONS
257
258None.
259
260
261=head1 DIAGNOSTICS
262
11f53956 263Errors from L<DBI|DBI>.
81f23a94
ES
264
265
266=head1 EXIT STATUS
267
2680
269
270
271=head1 CONFIGURATION
272
273None.
274
275
276=head1 DEPENDENCIES
277
11f53956
ES
278L<Perl::Critic|Perl::Critic>
279L<DBD::SQLite|DBD::SQLite>
280L<Perl6::Say|Perl6::Say>
281L<Readonly|Readonly>
81f23a94 282
11f53956
ES
283An SQLite database named "perl_critic_analysis.sqlite" with the
284following schema:
81f23a94
ES
285
286 CREATE TABLE violation (
287 file_path VARCHAR(1024),
288 line_number INTEGER,
289 column_number INTEGER,
290 severity INTEGER,
291 policy VARCHAR(512),
292 explanation TEXT,
293 source_code TEXT
294 )
295
296
297=head1 INCOMPATIBILITIES
298
299None reported.
300
301
302=head1 BUGS AND LIMITATIONS
303
304This is an example program and thus does minimal error handling.
305
306
307=head1 AUTHOR
308
309Elliot Shank C<< <perl@galumph.com> >>
310
311
ee0fa298 312=head1 COPYRIGHT
81f23a94 313
11f53956
ES
314Copyright (c) 2006-2007, Elliot Shank C<< <perl@galumph.com> >>. All
315rights reserved.
81f23a94 316
11f53956
ES
317This module is free software; you can redistribute it and/or modify it
318under the same terms as Perl itself. See L<perlartistic|perlartistic>.
81f23a94
ES
319
320
321=head1 DISCLAIMER OF WARRANTY
322
11f53956
ES
323BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
324FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT
325WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER
326PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND,
327EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
328IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
329PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
330SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME
331THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
332
333IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
334WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
335REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE LIABLE
336TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR
337CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
338SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
339RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
340FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
341SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
342DAMAGES.
81f23a94
ES
343
344=cut
345
346# Local Variables:
347# mode: cperl
348# cperl-indent-level: 4
349# fill-column: 78
350# indent-tabs-mode: nil
351# c-indentation-style: bsd
352# End:
96fed375 353# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :