Login
Clean up some self-compliance issues now that MagicNumbers
[gknop/Perl-Critic.git] / examples / loadanalysisdb
1 #!/usr/bin/perl
2
3 ##############################################################################
4 #      $URL$
5 #     $Date$
6 #   $Author$
7 # $Revision$
8 ##############################################################################
9
10 ## no critic (ErrorHandling::RequireUseOfExceptions)
11 use 5.008001;
12 use strict;
13 use warnings;
14
15 use version; our $VERSION = qv('1.002');
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 analyses
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 format, put
236 them into a database so that analyses can be made.
237
238 This example doesn't put anything into the database that isn't available from
239 L<Perl::Critic::Violation> in order to keep the code easier to understand.  In
240 a full application of the idea presented here, one might want to include the
241 current date and a distribution name in the database so that progress on
242 cleaning up a code corpus can be tracked.
243
244 Note the explanation attribute of L<Perl::Critic::Violation> is constant for
245 most policies, but some of them do provide more specific diagnostics of the
246 code in question.
247
248
249 =head1 REQUIRED ARGUMENTS
250
251 A list of paths to files and directories to find code in.
252
253
254 =head1 OPTIONS
255
256 None.
257
258
259 =head1 DIAGNOSTICS
260
261 Errors from L<DBI>.
262
263
264 =head1 EXIT STATUS
265
266 0
267
268
269 =head1 CONFIGURATION
270
271 None.
272
273
274 =head1 DEPENDENCIES
275
276 L<Perl::Critic>
277 L<DBD::SQLite>
278 L<Perl6::Say>
279 L<Readonly>
280
281 An SQLite database named "perl_critic_analysis.sqlite" with the following
282 schema:
283
284   CREATE TABLE violation (
285       file_path     VARCHAR(1024),
286       line_number   INTEGER,
287       column_number INTEGER,
288       severity      INTEGER,
289       policy        VARCHAR(512),
290       explanation   TEXT,
291       source_code   TEXT
292   )
293
294
295 =head1 INCOMPATIBILITIES
296
297 None reported.
298
299
300 =head1 BUGS AND LIMITATIONS
301
302 This is an example program and thus does minimal error handling.
303
304
305 =head1 AUTHOR
306
307 Elliot Shank  C<< <perl@galumph.com> >>
308
309
310 =head1 COPYRIGHT
311
312 Copyright (c) 2006-2007, Elliot Shank C<< <perl@galumph.com> >>. All rights
313 reserved.
314
315 This module is free software; you can redistribute it and/or modify it under
316 the same terms as Perl itself. See L<perlartistic>.
317
318
319 =head1 DISCLAIMER OF WARRANTY
320
321 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE
322 SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE
323 STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE
324 SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED,
325 INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
326 FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
327 PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE,
328 YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
329
330 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY
331 COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE
332 SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE LIABLE TO YOU FOR DAMAGES,
333 INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING
334 OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO
335 LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR
336 THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER
337 SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
338 POSSIBILITY OF SUCH DAMAGES.
339
340 =cut
341
342 # Local Variables:
343 #   mode: cperl
344 #   cperl-indent-level: 4
345 #   fill-column: 78
346 #   indent-tabs-mode: nil
347 #   c-indentation-style: bsd
348 # End:
349 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab :