#!/usr/bin/perl -w
# Copyright 2008, 2009, 2010, 2011, 2012, 2013 Kevin Ryde
# This file is part of Perl-Critic-Pulp.
#
# Perl-Critic-Pulp is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# Perl-Critic-Pulp is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Perl-Critic-Pulp. If not, see <http://www.gnu.org/licenses/>.
# Usage: churn.pl [--const] [--not] [--diag] [directories...]
#
# Run the pulp tests over all files under the given directories, or by
# default over /usr/share/perl (core and add-ons).
#
# The options select just one of the policies.
#
use 5.006;
use strict;
use warnings;
use Getopt::Long;
use lib 'lib','devel/lib';
use Perl::Critic;
use Perl::Critic::Utils;
use Perl::Critic::Violation;
my @option_policies;
my $option_t_files = 0;
GetOptions
(require_order => 1,
t => \$option_t_files,
F => sub {
push @option_policies, 'Documentation::RequireFilenameMarkup$';
},
paracomma => sub {
push @option_policies, 'Documentation::ProhibitParagraphEndComma$';
},
duphead => sub {
push @option_policies, 'Documentation::ProhibitDuplicateHeadings';
},
ifif => sub {
push @option_policies, 'CodeLayout::ProhibitIfIfSameLine';
},
duphashkeys => sub {
push @option_policies, 'ValuesAndExpressions::ProhibitDuplicateHashKeys';
},
linkself => sub {
push @option_policies, 'Documentation::ProhibitLinkSelf$';
},
unbal => sub {
push @option_policies, 'Documentation::inprogressProhibitUnbalancedParens';
},
aref => sub {
push @option_policies, 'ValuesAndExpressions::ProhibitArrayAssignAref';
},
const => sub {
push @option_policies, 'ValuesAndExpressions::ConstantBeforeLt';
},
not => sub {
push @option_policies, 'ValuesAndExpressions::NotWithCompare';
},
null => sub {
push @option_policies, 'ValuesAndExpressions::ProhibitNullStatements';
},
literals => sub {
push @option_policies, 'ValuesAndExpressions::UnexpandedSpecialLiteral';
},
commas => sub {
push @option_policies, 'ValuesAndExpressions::ProhibitEmptyCommas';
},
lastpod => sub {
push @option_policies, 'Documentation::RequireEndBeforeLastPod';
},
consthash => sub {
push @option_policies, 'Compatibility::ConstantPragmaHash';
},
gtk2 => sub {
push @option_policies, 'Modules::Gtk2Version';
},
podmin => sub {
push @option_policies, 'Compatibility::PodMinimumVersion';
},
posix => sub {
push @option_policies, 'Modules::ProhibitPOSIXimport';
},
usever => sub {
push @option_policies, 'Modules::ProhibitUseQuotedVersion';
},
apropos => sub {
push @option_policies, 'Documentation::ProhibitBadAproposMarkup';
},
backslash => sub {
push @option_policies, 'ValuesAndExpressions::ProhibitUnknownBackslash';
},
semicolon => sub {
push @option_policies, 'CodeLayout::RequireFinalSemicolon';
},
verb => sub {
push @option_policies, 'Documentation::ProhibitVerbatimMarkup$';
},
shebang => sub {
push @option_policies, 'Modules::ProhibitModuleShebang$';
},
numver => sub {
push @option_policies, 'ValuesAndExpressions::RequireNumericVersion';
},
# coming soon ...
fatnewline => sub {
push @option_policies, 'ProhibitFatCommaAfterNewline';
},
testprint => sub {
push @option_policies, 'TestingAndDebugging::ProhibitTestPrint';
},
trailing => sub {
push @option_policies, 'CodeLayout::RequireTrailingCommaAtNewline';
},
);
my @files;
if ($option_t_files) {
require File::Locate;
@files = File::Locate::locate ('*.t', '/var/cache/locate/locatedb');
} else {
my @dirs = @ARGV;
if (! @dirs) {
@dirs = (
'/usr/share/perl5',
'/usr/bin',
'/bin',
glob('/usr/share/perl/*.*.*'),
);
}
print "Directories:\n";
foreach (@dirs) {
print " ",$_,"\n";
}
@files = map { -d $_ ? Perl::Critic::Utils::all_perl_files($_) : $_ } @dirs;
}
@files = uniq_by_func (\&stat_dev_ino, @files);
print "Files: ",scalar(@files),"\n";
# @list = uniq_by_func ($func, @list)
sub uniq_by_func {
my $func = shift;
my %seen;
return grep { my $key = $func->($_);
defined $key && $seen{$key}++ == 0
} @_;
}
sub stat_dev_ino {
my ($filename) = @_;
my ($dev, $ino) = stat ($filename);
return if ! defined $dev;
return "$dev,$ino";
}
my $critic;
if (@option_policies) {
$critic = Perl::Critic->new ('-profile' => '',
'-single-policy' => shift @option_policies);
foreach my $policy (@option_policies) {
$critic->add_policy (-policy => $policy);
}
} else {
$critic = Perl::Critic->new ('-profile' => '',
'-theme' => 'pulp');
}
# $critic->add_policy
# (-policy => 'ValuesAndExpressions::ProhibitNullStatements',
# -params => { allow_perl4_semihash => 1 });
print "Policies:\n";
foreach my $p ($critic->policies) {
print " ",$p->get_short_name,"\n";
}
# "%f:%l:%c:" is good for emacs compilation-mode
Perl::Critic::Violation::set_format ("%f:%l:%c:\n %P\n %m\n %r\n");
foreach my $file (@files) {
print "$file\n";
my @violations;
if (! eval { @violations = $critic->critique ($file); 1 }) {
print "Died in \"$file\": $@\n";
next;
}
print @violations;
if (my $exception = Perl::Critic::Exception::Parse->caught) {
print "Caught exception in \"$file\": $exception\n";
}
}
exit 0;