use 5.006001;
:characters :severities policy_short_name
$DEFAULT_VERBOSITY $DEFAULT_VERBOSITY_WITH_FILE_NAME
>;
our $VERSION = '1.097_002';
Readonly::Array our @EXPORT_OK => qw< run >;
Readonly::Hash our %EXPORT_TAGS => (
all => [ @EXPORT_OK ],
);
Readonly::Scalar my $DEFAULT_VIOLATIONS_FOR_TOP => 20;
Readonly::Scalar my $EXIT_SUCCESS => 0;
Readonly::Scalar my $EXIT_NO_FILES => 1;
Readonly::Scalar my $EXIT_HAD_VIOLATIONS => 2;
Readonly::Scalar my $EXIT_HAD_FILE_PROBLEMS => 3;
my @files = ();
my $critic = undef;
my $output = \*STDOUT;
sub _out {
my @lines = @_;
return print {$output} @lines;
}
sub run {
my %options = _get_options();
@files = _get_input(@ARGV);
my ($violations, $had_error_in_file) = _critique(\%options, @files);
return $EXIT_HAD_FILE_PROBLEMS if $had_error_in_file;
return $EXIT_NO_FILES if not defined $violations;
return $EXIT_HAD_VIOLATIONS if $violations;
return $EXIT_SUCCESS;
}
sub _get_options {
my %opts = _parse_command_line();
_dispatch_special_requests( %opts );
_validate_options( %opts );
$opts{-severity} ||= first { exists $opts{"-$_"} } @SEVERITY_NAMES;
$opts{-severity} ||= first { exists $opts{"-$_"} } ($SEVERITY_LOWEST .. $SEVERITY_HIGHEST);
if ( exists $opts{-top} ) {
$opts{-severity} ||= 1;
$opts{-top} ||= $DEFAULT_VIOLATIONS_FOR_TOP;
}
if ( exists $opts{-noprofile} ) {
$opts{-profile} = $EMPTY;
}
return %opts;
}
sub _parse_command_line {
my %opts;
my @opt_specs = _get_option_specification();
Getopt::Long::Configure('no_ignore_case');
GetOptions( \%opts, @opt_specs ) || pod2usage();
my %dashed_opts = map { ( "-$_" => $opts{$_} ) } keys %opts;
return %dashed_opts;
}
sub _dispatch_special_requests {
my (%opts) = @_;
if ( $opts{-help} ) { pod2usage( -verbose => 0 ) }
if ( $opts{-options} ) { pod2usage( -verbose => 1 ) }
if ( $opts{-man} ) { pod2usage( -verbose => 2 ) }
if ( $opts{-version} ) { _display_version() }
if ( $opts{-list} ) { _render_policy_listing() }
if ( $opts{'-list-themes'} ) { _render_theme_listing() }
if ( $opts{'-profile-proto'} ) { _render_profile_prototype() }
if ( $opts{-doc} ) { _render_policy_docs( %opts ) }
return 1;
}
sub _validate_options {
my (%opts) = @_;
my $msg = $EMPTY;
if ( $opts{-noprofile} && $opts{-profile} ) {
$msg .= qq{Warning: Cannot use -noprofile with -profile option.\n};
}
if ( $opts{-verbose} && $opts{-verbose} !~ m{(?: \d+ | %[mfFlcedrpPs] )}xms) {
$msg .= qq<Warning: --verbose arg "$opts{-verbose}" looks odd. >;
$msg .= qq<Perhaps you meant to say "--verbose 3 $opts{-verbose}."\n>;
}
if ( exists $opts{-top} && $opts{-top} < 0 ) {
$msg .= qq<Warning: --top argument "$opts{-top}" is negative. >;
$msg .= qq<Perhaps you meant to say "$opts{-top} --top".\n>;
}
if (
exists $opts{-severity}
&& (
$opts{-severity} < $SEVERITY_LOWEST
|| $opts{-severity} > $SEVERITY_HIGHEST
)
) {
$msg .= qq<Warning: --severity arg "$opts{-severity}" out of range. >;
$msg .= qq<Severities range from "$SEVERITY_LOWEST" (lowest) to >;
$msg .= qq<"$SEVERITY_HIGHEST" (highest).\n>;
}
if ( $msg ) {
pod2usage( -exitstatus => 1, -message => $msg, -verbose => 0);
}
return 1;
}
sub _get_input {
my @args = @_;
if ( !@args || (@args == 1 && $args[0] eq q{-}) ) {
my $code_string = do { local $RS = undef; <STDIN> };
if ( ! defined $code_string ) {
$code_string = $EMPTY;
}
$code_string =~ m{ \S+ }xms || die qq{Nothing to critique.\n};
return \$code_string;
}
else {
if ( my $nonexistent = first { ! -e $_ } @args ) {
my $msg = qq{No such file or directory: '$nonexistent'};
pod2usage( -exitstatus => 1, -message => $msg, -verbose => 0);
}
return map { -d $_ ? Perl::Critic::Utils::all_perl_files($_) : $_ } @args;
}
}
sub _critique {
my ( $opts_ref, @files_to_critique ) = @_;
@files_to_critique || die "No perl files were found.\n";
$critic = Perl::Critic->new( %{$opts_ref} );
$critic->policies() || die "No policies selected.\n";
_set_up_pager($critic->config()->pager());
my $number_of_violations = undef;
my $had_error_in_file = 0;
for my $file (@files_to_critique) {
eval {
my @violations = $critic->critique($file);
$number_of_violations += scalar @violations;
if (not $opts_ref->{'-statistics-only'}) {
_render_report( $file, $opts_ref, @violations )
}
1;
}
or do {
if ( my $exception = Perl::Critic::Exception::Parse->caught() ) {
$had_error_in_file = 1;
warn qq<Problem while critiquing "$file": $EVAL_ERROR\n>;
}
elsif ($EVAL_ERROR) {
die qq<Fatal error while critiquing "$file": $EVAL_ERROR\n>;
}
else {
die qq<Fatal error while critiquing "$file". Unfortunately, >,
q<$@/$EVAL_ERROR >,
qq<is empty, so the reason can't be shown.\n>;
}
}
}
if ( $opts_ref->{-statistics} or $opts_ref->{'-statistics-only'} ) {
my $stats = $critic->statistics();
_report_statistics( $opts_ref, $stats );
}
return $number_of_violations, $had_error_in_file;
}
sub _render_report {
my ( $file, $opts_ref, @violations ) = @_;
my $number_of_violations = scalar @violations;
if( $opts_ref->{-count} ){
ref $file || _out "$file: ";
_out "$number_of_violations\n";
return $number_of_violations;
}
if( !@violations && !$opts_ref->{-quiet} ) {
ref $file || _out "$file ";
_out "source OK\n";
return 0;
}
my $verbosity = $critic->config->verbose();
$verbosity =
($verbosity eq $DEFAULT_VERBOSITY && @files > 1)
? $DEFAULT_VERBOSITY_WITH_FILE_NAME
: $verbosity;
my $fmt = Perl::Critic::Utils::verbosity_to_format( $verbosity );
if (not -f $file) { $fmt =~ s< \%[fF] ><STDIN>xms; }
Perl::Critic::Violation::set_format( $fmt );
my $color = $critic->config->color();
_out $color ? _colorize_by_severity(@violations) : @violations;
return $number_of_violations;
}
sub _set_up_pager {
my ($pager_command) = @_;
return if not $pager_command;
return if not _at_tty();
open my $pager, q<|->, $pager_command
or die qq<Unable to pipe to pager "$pager_command": $ERRNO\n>;
$output = $pager;
return;
}
sub _report_statistics {
my ($opts_ref, $statistics) = @_;
if (
not $opts_ref->{'-statistics-only'}
and (
$statistics->total_violations()
or not $opts_ref->{-quiet} and $statistics->modules()
)
) {
_out "\n";
}
my $files = _commaify($statistics->modules());
my $subroutines = _commaify($statistics->subs());
my $statements = _commaify($statistics->statements_other_than_subs());
my $lines = _commaify($statistics->lines());
my $width = max map { length } $files, $subroutines, $statements, $lines;
_out sprintf "%*s %s.\n", $width, $files, 'files';
_out sprintf "%*s %s.\n", $width, $subroutines, 'subroutines/methods';
_out sprintf "%*s %s.\n", $width, $statements, 'statements';
_out sprintf "%*s %s.\n", $width, $lines, 'lines';
my $average_sub_mccabe = $statistics->average_sub_mccabe();
if (defined $average_sub_mccabe) {
_out
sprintf
"\nAverage McCabe score of subroutines was %.2f.\n",
$average_sub_mccabe;
}
_out "\n";
_out _commaify($statistics->total_violations()), " violations.\n";
my $violations_per_file = $statistics->violations_per_file();
if (defined $violations_per_file) {
_out
sprintf
"Violations per file was %.3f.\n",
$violations_per_file;
}
my $violations_per_statement = $statistics->violations_per_statement();
if (defined $violations_per_statement) {
_out
sprintf
"Violations per statement was %.3f.\n",
$violations_per_statement;
}
my $violations_per_line = $statistics->violations_per_line_of_code();
if (defined $violations_per_line) {
_out
sprintf
"Violations per line of code was %.3f.\n",
$violations_per_line;
}
if ( $statistics->total_violations() ) {
_out "\n";
my %severity_violations = %{ $statistics->violations_by_severity() };
my @severities = reverse sort keys %severity_violations;
$width =
max
map { length _commaify( $severity_violations{$_} ) }
@severities;
foreach my $severity (@severities) {
_out
sprintf
"%*s severity %d violations.\n",
$width,
_commaify( $severity_violations{$severity} ),
$severity;
}
_out "\n";
my %policy_violations = %{ $statistics->violations_by_policy() };
my @policies = sort keys %policy_violations;
$width =
max
map { length _commaify( $policy_violations{$_} ) }
@policies;
foreach my $policy (@policies) {
_out
sprintf
"%*s violations of %s.\n",
$width,
_commaify($policy_violations{$policy}),
policy_short_name($policy);
}
}
return;
}
sub _commaify {
my ( $number ) = @_;
while ($number =~ s/ \A ( [-+]? \d+ ) ( \d{3} ) /$1,$2/xms) {
}
return $number;
}
sub _get_option_specification {
return qw(
5 4 3 2 1
Safari
version
brutal
count|C
cruel
doc=s
exclude=s@
force!
gentle
harsh
help|?|H
include=s@
list
list-themes
man
color|colour!
noprofile
only!
options
pager=s
profile|p=s
profile-proto
quiet
severity=i
single-policy|s=s
stern
statistics!
statistics-only!
profile-strictness=s
theme=s
top:i
verbose=s
color-severity-highest|colour-severity-highest|color-severity-5|colour-severity-5=s
color-severity-high|colour-severity-high|color-severity-4|colour-severity-4=s
color-severity-medium|colour-severity-medium|color-severity-3|colour-severity-3=s
color-severity-low|colour-severity-low|color-severity-2|colour-severity-2=s
color-severity-lowest|colour-severity-lowest|color-severity-1|colour-severity-1=s
);
}
sub _colorize_by_severity {
my @violations = @_;
return @violations if _this_is_windows();
my $config = $critic->config();
my %color_of = (
$SEVERITY_HIGHEST => $config->color_severity_highest(),
$SEVERITY_HIGH => $config->color_severity_high(),
$SEVERITY_MEDIUM => $config->color_severity_medium(),
$SEVERITY_LOW => $config->color_severity_low(),
$SEVERITY_LOWEST => $config->color_severity_lowest(),
);
return map { _colorize( "$_", $color_of{$_->severity()} ) } @violations;
}
sub _colorize {
my ($string, $color) = @_;
return $string if not defined $color;
return $string if $color eq $EMPTY;
my $terminator = chomp $string ? "\n" : $EMPTY;
return Term::ANSIColor::colored( $string, $color ) . $terminator;
}
sub _this_is_windows {
return 1 if $OSNAME =~ m/MSWin32/xms;
return 0;
}
sub _at_tty {
return -t STDOUT;
}
sub _render_policy_listing {
my %pc_params = (-profile => $EMPTY, -severity => $SEVERITY_LOWEST);
my @policies = Perl::Critic->new( %pc_params )->policies();
my $listing = Perl::Critic::PolicyListing->new( -policies => \@policies );
_out $listing;
exit $EXIT_SUCCESS;
}
sub _render_theme_listing {
my %pc_params = (-profile => $EMPTY, -severity => $SEVERITY_LOWEST);
my @policies = Perl::Critic->new( %pc_params )->policies();
my $listing = Perl::Critic::ThemeListing->new( -policies => \@policies );
_out $listing;
exit $EXIT_SUCCESS;
}
sub _render_profile_prototype {
my %pc_params = (-profile => $EMPTY, -severity => $SEVERITY_LOWEST);
my @policies = Perl::Critic->new( %pc_params )->policies();
my $prototype = Perl::Critic::ProfilePrototype->new( -policies => \@policies );
_out $prototype;
exit $EXIT_SUCCESS;
}
sub _render_policy_docs {
my (%opts) = @_;
my $pattern = delete $opts{-doc};
$critic = Perl::Critic->new(%opts);
_set_up_pager($critic->config()->pager());
my @site_policies = Perl::Critic::PolicyFactory->site_policy_names();
my @matching_policies = grep { $_ =~ m/$pattern/ixms } @site_policies;
my @perldoc_output = map {`perldoc -T $_`} @matching_policies;
_out @perldoc_output;
exit $EXIT_SUCCESS;
}
sub _display_version {
_out "$VERSION\n";
exit $EXIT_SUCCESS;
}
1;