Login
Now that we have ProhibitUselessNoCritic, we can
[gknop/Perl-Critic.git] / examples / loadanalysisdb
1 #!/usr/bin/perl
2
3 ##############################################################################
4 #      $URL$
5 #     $Date$
6 #   $Author$
7 # $Revision$
8 ##############################################################################
9
10
11 use 5.008001;
12 use strict;
13 use warnings;
14
15 use version; our $VERSION = qv('1.093_001');
16
17 use Carp qw{ croak };
18 use English qw{ -no_match_vars };
19 use Readonly;
20
21 use DBI qw{ :sql_types };
22 use File::Spec qw{ };
23 use Perl6::Say;
24
25 use Perl::Critic::Utils qw{ all_perl_files policy_short_name $EMPTY };
26 use Perl::Critic;
27
28
29 if ( ! @ARGV ) {
30     die qq{usage: loadanalysisdb path [...]\n};
31 }
32
33 main();
34
35 exit 0;
36
37
38 sub 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
72 sub 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
112 sub 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
133 sub 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                 (?, ?, ?, ?, ?, ?, ?)
151 END_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
157     # bind_param()" on pages 126-7 of "Programming the Perl DBI".
158
159     ## no critic (ProhibitMagicNumbers)
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);
166     $insert_statement->bind_param( 7, 'x', SQL_VARCHAR);
167     ## use critic
168
169     return $insert_statement;
170 }
171
172
173 sub execute_insert_statement {  ##no critic(ProhibitManyArgs)
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
200 sub close_insert_statement {
201     my ( $insert_statement ) = @_;
202
203     $insert_statement->finish();
204
205     return;
206 }
207
208 sub disconnect_from_database {
209     my ( $database_connection ) = @_;
210
211     $database_connection->disconnect();
212
213     return;
214 }
215
216
217 __END__
218
219 =pod
220
221 =for stopwords SQLite DBI analyses perlartistic
222
223 =head1 NAME
224
225 C<loadanalysisdb> - Critique a body of code and load the results into a database for later processing.
226
227
228 =head1 USAGE
229
230     loadanalysisdb path [...]
231
232
233 =head1 DESCRIPTION
234
235 Scan a body of code and, rather than emit the results in a textual
236 format, put them into a database so that analyses can be made.
237
238 This example doesn't put anything into the database that isn't
239 available from L<Perl::Critic::Violation|Perl::Critic::Violation> in
240 order to keep the code easier to understand.  In a full application of
241 the idea presented here, one might want to include the current date
242 and a distribution name in the database so that progress on cleaning
243 up a code corpus can be tracked.
244
245 Note the explanation attribute of
246 L<Perl::Critic::Violation|Perl::Critic::Violation> is constant for
247 most policies, but some of them do provide more specific diagnostics
248 of the code in question.
249
250
251 =head1 REQUIRED ARGUMENTS
252
253 A list of paths to files and directories to find code in.
254
255
256 =head1 OPTIONS
257
258 None.
259
260
261 =head1 DIAGNOSTICS
262
263 Errors from L<DBI|DBI>.
264
265
266 =head1 EXIT STATUS
267
268 0
269
270
271 =head1 CONFIGURATION
272
273 None.
274
275
276 =head1 DEPENDENCIES
277
278 L<Perl::Critic|Perl::Critic>
279 L<DBD::SQLite|DBD::SQLite>
280 L<Perl6::Say|Perl6::Say>
281 L<Readonly|Readonly>
282
283 An SQLite database named "perl_critic_analysis.sqlite" with the
284 following schema:
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
299 None reported.
300
301
302 =head1 BUGS AND LIMITATIONS
303
304 This is an example program and thus does minimal error handling.
305
306
307 =head1 AUTHOR
308
309 Elliot Shank  C<< <perl@galumph.com> >>
310
311
312 =head1 COPYRIGHT
313
314 Copyright (c) 2006-2007, Elliot Shank C<< <perl@galumph.com> >>. All
315 rights reserved.
316
317 This module is free software; you can redistribute it and/or modify it
318 under the same terms as Perl itself. See L<perlartistic|perlartistic>.
319
320
321 =head1 DISCLAIMER OF WARRANTY
322
323 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
324 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT
325 WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER
326 PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND,
327 EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
328 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
329 PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
330 SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME
331 THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
332
333 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
334 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
335 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE LIABLE
336 TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR
337 CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
338 SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
339 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
340 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
341 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
342 DAMAGES.
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:
353 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :