3 ##############################################################################
4 # $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/examples/loadanalysisdb $
5 # $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
8 ##############################################################################
10 ## no critic (ErrorHandling::RequireUseOfExceptions)
15 use version; our $VERSION = qv('1.002');
18 use English qw{ -no_match_vars };
21 use DBI qw{ :sql_types };
25 use Perl::Critic::Utils qw{ all_perl_files policy_short_name $EMPTY };
30 die qq{usage: loadanalysisdb path [...]\n};
39 say 'Connecting to database.';
42 my $database_connection = connect_to_database();
43 my $insert_statement = prepare_insert_statement($database_connection);
45 foreach my $path ( @ARGV ) {
46 say "Looking at $path.";
48 my @files = all_perl_files($path);
49 say 'Analyzing ', scalar @files, ' files.';
51 load( \@files, File::Spec->canonpath($path), $insert_statement );
56 say 'Disconnecting from database.';
59 close_insert_statement($insert_statement);
60 # Need to do this or DBI emits warning at disconnect
61 $insert_statement = undef;
63 disconnect_from_database($database_connection);
73 my ( $files, $path, $insert_statement ) = @_;
75 # Force reporting level to be really strict, just so that the database
77 my $critic = Perl::Critic->new( -severity => 1 );
79 foreach my $file ( @{$files} ) {
83 $relative_path = $file;
85 my $absolute_path_length = ( length $path ) + 1;
87 $relative_path = substr $file, $absolute_path_length;
90 say "Processing $relative_path.";
92 foreach my $violation ( $critic->critique($file) ) {
93 my ($line, $column) = @{ $violation->location() };
95 execute_insert_statement(
100 $violation->severity(),
101 policy_short_name( $violation->policy() ),
102 $violation->explanation(),
103 $violation->source(),
112 sub connect_to_database {
113 my $database_file_name = 'perl_critic_analysis.sqlite';
115 my $database_connection =
117 "dbi:SQLite:dbname=$database_file_name",
121 AutoCommit => 1, # In real life, this should be 0
126 defined $database_connection or
127 croak "Could not connect to $database_file_name.";
129 return $database_connection;
133 sub prepare_insert_statement {
134 my ( $database_connection ) = @_;
136 my $insert_statement =
137 $database_connection->prepare(<<'END_SQL');
150 (?, ?, ?, ?, ?, ?, ?)
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".
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);
169 return $insert_statement;
173 sub execute_insert_statement { ##no critic(ProhibitManyArgs)
200 sub close_insert_statement {
201 my ( $insert_statement ) = @_;
203 $insert_statement->finish();
208 sub disconnect_from_database {
209 my ( $database_connection ) = @_;
211 $database_connection->disconnect();
221 =for stopwords SQLite analyses
225 C<loadanalysisdb> - Critique a body of code and load the results into a database for later processing.
230 loadanalysisdb path [...]
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.
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.
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
249 =head1 REQUIRED ARGUMENTS
251 A list of paths to files and directories to find code in.
281 An SQLite database named "perl_critic_analysis.sqlite" with the following
284 CREATE TABLE violation (
285 file_path VARCHAR(1024),
287 column_number INTEGER,
295 =head1 INCOMPATIBILITIES
300 =head1 BUGS AND LIMITATIONS
302 This is an example program and thus does minimal error handling.
307 Elliot Shank C<< <perl@galumph.com> >>
312 Copyright (c) 2006-2007, Elliot Shank C<< <perl@galumph.com> >>. All rights
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>.
319 =head1 DISCLAIMER OF WARRANTY
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.
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.
344 # cperl-indent-level: 4
346 # indent-tabs-mode: nil
347 # c-indentation-style: bsd
349 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :