vcs.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/examples/generatestats

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