examples/generatestats

   1 #!/usr/bin/perl
   2
   3 ##############################################################################
   4 #      $URL$
   5 #     $Date$
   6 #   $Author$
   7 # $Revision$
   8 ##############################################################################
   9
  10 use 5.008001;
  11 use strict;
  12 use warnings;
  13
  14 use version; our $VERSION = qv('1.116');
  15
  16 use Carp qw{ croak };
  17 use English qw{ -no_match_vars };
  18 use Readonly;
  19
  20 use File::Spec qw{ };
  21 use Perl6::Say;
  22
  23 use Perl::Critic::Utils qw{ all_perl_files };
  24 use Perl::Critic;
  25
  26
  27 if ( ! @ARGV ) {
  28     die qq{usage: generatestats path [...]\n};
  29 }
  30
  31 main();
  32
  33 exit 0;
  34
  35
  36 sub main {
  37     foreach my $path ( @ARGV ) {
  38         say "Looking at $path.";
  39
  40         my @files = all_perl_files($path);
  41         say 'Analyzing ', scalar @files, ' files.';
  42
  43         my $results = summarize( \@files, File::Spec->canonpath($path) );
  44
  45         report($results);
  46
  47         say; say;
  48     }
  49
  50     return;
  51 }
  52
  53
  54 sub summarize {
  55     my ( $files, $path ) = @_;
  56
  57     # Force reporting level to be really strict, just so that the statistics
  58     # include everything.
  59     my $critic = Perl::Critic->new( -severity => 1 );
  60
  61     my %total_severities;
  62     my %total_policies;
  63     my %types;
  64     my %files;
  65
  66     foreach my $file ( @{$files} ) {
  67         my $relative_path;
  68         my $type;
  69
  70         if ($file eq $path) {
  71             $relative_path = $file;
  72         } else {
  73             my $absolute_path_length = ( length $path ) + 1;
  74
  75             $relative_path = substr $file, $absolute_path_length;
  76         }
  77
  78         if ($file =~ m/ [.] ([^.]+) \z /xms) {
  79             $type = $1;
  80         } else {
  81             $type = '<program>';
  82         }
  83
  84         $types{$type}{files}++;
  85         foreach my $violation ( $critic->critique($file) ) {
  86             $files{ $relative_path }{ severities }{ $violation->severity() }++;
  87             $files{ $relative_path }{ policies   }{ $violation->policy()   }++;
  88
  89             $types{ $type          }{ severities }{ $violation->severity() }++;
  90             $types{ $type          }{ policies   }{ $violation->policy()   }++;
  91
  92             $total_severities{ $violation->severity() }++;
  93             $total_policies{   $violation->policy()   }++;
  94         }
  95     }
  96
  97     return {
  98         severities  => \%total_severities,
  99         policies    => \%total_policies,
 100         types       => \%types,
 101         files       => \%files,
 102     };
 103 }
 104
 105
 106 sub report {
 107     my ( $results ) = @_;
 108
 109     report_totals( $results );
 110     report_types(  $results );
 111     report_files(  $results );
 112
 113     return;
 114 }
 115
 116
 117 sub report_totals {
 118     my ( $results ) = @_;
 119
 120     say;
 121     say 'Total violations by severity:';
 122     report_severities( $results->{severities} );
 123
 124     say;
 125     say 'Total violations by policy:';
 126     report_policies( $results->{policies} );
 127
 128     return;
 129 }
 130
 131
 132 sub report_types {
 133     my ( $results ) = @_;
 134     my   $types     = $results->{types};
 135
 136     say;
 137     say 'Total files by type:';
 138     foreach my $type ( sort keys %{$types} ) {
 139         say qq{\t}, $type, ': ', $types->{$type}{files};
 140     }
 141
 142     foreach my $type ( sort keys %{$types} ) {
 143         say;
 144         say "Violations in $type files by severity:";
 145         report_severities( $types->{$type}{severities} );
 146
 147         say;
 148         say "Violations in $type files by policy:";
 149         report_policies( $types->{$type}{policies} );
 150     }
 151
 152     return;
 153 }
 154
 155
 156 sub report_files {
 157     my ( $results ) = @_;
 158     my   $files     = $results->{files};
 159
 160     foreach my $file ( sort keys %{$files} ) {
 161         say;
 162         say "Violations in $file by severity:";
 163         report_severities( $files->{$file}{severities} );
 164
 165         say;
 166         say "Violations in $file by policy:";
 167         report_policies( $files->{$file}{policies} );
 168     }
 169
 170     return;
 171 }
 172
 173
 174 sub report_severities {
 175     my ($severities) = @_;
 176
 177     foreach my $severity ( reverse sort { $a <=> $b } keys %{$severities} ) {
 178         say qq{\t}, $severity, ': ', $severities->{$severity};
 179     }
 180
 181     return;
 182 }
 183
 184
 185 sub report_policies {
 186     my ($policies) = @_;
 187
 188     foreach my $policy ( sort keys %{$policies} ) {
 189         (my $short_policy = $policy) =~ s/ \A Perl::Critic::Policy:: //xms;
 190
 191         say qq{\t}, $short_policy, ': ', $policies->{$policy};
 192     }
 193
 194     return;
 195 }
 196
 197
 198 __END__
 199
 200 =pod
 201
 202 =for stopwords codebase perlartistic
 203
 204 =head1 NAME
 205
 206 C<generatestats> - Produce some simple quality statistics of a codebase
 207
 208
 209 =head1 USAGE
 210
 211     generatestats path [...]
 212
 213
 214 =head1 DESCRIPTION
 215
 216 Scan a body of code and generate some statistics on violations of the
 217 installed L<Perl::Critic|Perl::Critic> policies.  While there is no means of
 218 configuring the policies here, this will take into account your
 219 F<.perlcriticrc>, if available.
 220
 221
 222 =head1 REQUIRED ARGUMENTS
 223
 224 A list of paths to files and directories to find code in.
 225
 226
 227 =head1 OPTIONS
 228
 229 None.
 230
 231
 232 =head1 DIAGNOSTICS
 233
 234 None.
 235
 236
 237 =head1 EXIT STATUS
 238
 239 0
 240
 241
 242 =head1 CONFIGURATION
 243
 244 None.
 245
 246
 247 =head1 DEPENDENCIES
 248
 249 L<Perl::Critic|Perl::Critic>
 250 L<Perl6::Say|Perl6::Say>
 251 L<Readonly|Readonly>
 252
 253
 254 =head1 INCOMPATIBILITIES
 255
 256 None reported.
 257
 258
 259 =head1 BUGS AND LIMITATIONS
 260
 261 This is an example program and thus does minimal error handling.
 262
 263
 264 =head1 AUTHOR
 265
 266 Elliot Shank  C<< <perl@galumph.com> >>
 267
 268
 269 =head1 COPYRIGHT
 270
 271 Copyright (c) 2006-2011, Elliot Shank.
 272
 273 This module is free software; you can redistribute it and/or modify it under
 274 the same terms as Perl itself. See L<perlartistic|perlartistic>.
 275
 276
 277 =head1 DISCLAIMER OF WARRANTY
 278
 279 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE
 280 SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE
 281 STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE
 282 SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED,
 283 INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
 284 FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
 285 PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE,
 286 YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
 287
 288 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY
 289 COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE
 290 SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE LIABLE TO YOU FOR DAMAGES,
 291 INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING
 292 OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO
 293 LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR
 294 THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER
 295 SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
 296 POSSIBILITY OF SUCH DAMAGES.
 297
 298 =cut
 299
 300 # Local Variables:
 301 #   mode: cperl
 302 #   cperl-indent-level: 4
 303 #   fill-column: 78
 304 #   indent-tabs-mode: nil
 305 #   c-indentation-style: bsd
 306 # End:
 307 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :