Perl::Critic::Command - Guts of L<perlcritic|perlcritic>.

Perl-Critic documentation Contained in the Perl-Critic distribution.

Index

Code Index:

NAME

Top

Perl::Critic::Command - Guts of perlcritic (perlcritic).

SYNOPSIS

Top

    use Perl::Critic::Command qw< run >;

    local @ARGV = qw< --statistics-only lib bin >;
    run();

DESCRIPTION

Top

This is the implementation of the perlcritic (perlcritic) command. You can use this to run the command without going through a command interpreter.

INTERFACE SUPPORT

Top

This is considered to be a public class. However, its interface is experimental, and will likely change.

IMPORTABLE SUBROUTINES

Top

run()

Does the equivalent of the perlcritic (perlcritic) command. Unfortunately, at present, this doesn't take any parameters but uses @ARGV to get its input instead. Count on this changing; don't count on the current interface.

TO DO

Top

Make run() take parameters. The equivalent of @ARGV should be passed as a reference.

Turn this into an object.

AUTHOR

Top

Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>

COPYRIGHT

Top

Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of this license can be found in the LICENSE file included with this module.

Perl-Critic documentation Contained in the Perl-Critic distribution. 
##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/lib/Perl/Critic/Command.pm $
#     $Date: 2011-05-15 16:34:46 -0500 (Sun, 15 May 2011) $
#   $Author: clonezone $
# $Revision: 4078 $
##############################################################################

package Perl::Critic::Command;

use 5.006001;
use strict;
use warnings;

use English qw< -no_match_vars >;
use Readonly;

use Getopt::Long qw< GetOptions >;
use List::Util qw< first max >;
use Pod::Usage qw< pod2usage >;

use Perl::Critic::Exception::Parse ();
use Perl::Critic::Utils qw<
    :characters :severities policy_short_name
    $DEFAULT_VERBOSITY $DEFAULT_VERBOSITY_WITH_FILE_NAME
>;
use Perl::Critic::Utils::Constants qw< $_MODULE_VERSION_TERM_ANSICOLOR >;
use Perl::Critic::Violation qw<>;

#-----------------------------------------------------------------------------

our $VERSION = '1.116';

#-----------------------------------------------------------------------------

use base 'Exporter';

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 );

    # Convert severity shortcut options.  If multiple shortcuts
    # are given, the lowest one wins.  If an explicit --severity
    # option has been given, then the shortcuts are ignored. The
    # @SEVERITY_NAMES variable is exported by Perl::Critic::Utils.
    $opts{-severity} ||= first { exists $opts{"-$_"} } @SEVERITY_NAMES;
    $opts{-severity} ||= first { exists $opts{"-$_"} } ($SEVERITY_LOWEST ..  $SEVERITY_HIGHEST);


    # If --top is specified, default the severity level to 1, unless an
    # explicit severity is defined.  This provides us flexibility to
    # report top-offenders across just some or all of the severity levels.
    # We also default the --top count to twenty if none is given
    if ( exists $opts{-top} ) {
        $opts{-severity} ||= 1;
        $opts{-top} ||= $DEFAULT_VIOLATIONS_FOR_TOP;
    }

    #Override profile, if --noprofile is specified
    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();           #Exits

    # I've adopted the convention of using key-value pairs for
    # arguments to most functions.  And to increase legibility,
    # I have also adopted the familiar command-line practice
    # of denoting argument names with a leading dash (-).
    my %dashed_opts = map { ( "-$_" => $opts{$_} ) } keys %opts;
    return %dashed_opts;
}

#-----------------------------------------------------------------------------

sub _dispatch_special_requests {
    my (%opts) = @_;
    if ( $opts{-help}            ) { pod2usage( -verbose => 0 )    }  # Exits
    if ( $opts{-options}         ) { pod2usage( -verbose => 1 )    }  # Exits
    if ( $opts{-man}             ) { pod2usage( -verbose => 2 )    }  # Exits
    if ( $opts{-version}         ) { _display_version()            }  # Exits
    if ( $opts{-list}            ) { _render_all_policy_listing()  }  # Exits
    if ( $opts{'-list-enabled'}  ) { _render_policy_listing(%opts) }  # Exits
    if ( $opts{'-list-themes'}   ) { _render_theme_listing()       }  # Exits
    if ( $opts{'-profile-proto'} ) { _render_profile_prototype()   }  # Exits
    if ( $opts{-doc}             ) { _render_policy_docs( %opts )  }  # Exits
    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+ | %[mfFlcCedrpPs] )}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); #Exits
    }


    return 1;
}

#-----------------------------------------------------------------------------

sub _get_input {

    my @args = @_;

    if ( !@args || (@args == 1 && $args[0] eq q{-}) )  {

        # Reading code from STDIN.  All the code is slurped into
        # a string.  PPI will barf if the string is just whitespace.
        my $code_string = do { local $RS = undef; <STDIN> };

        # Notice if STDIN was closed (pipe error, etc)
        if ( ! defined $code_string ) {
            $code_string = $EMPTY;
        }

        $code_string =~ m{ \S+ }xms || die qq{Nothing to critique.\n};
        return \$code_string;    #Convert to SCALAR ref for PPI
    }
    else {

        # Test to make sure all the specified files or directories
        # actually exist.  If any one of them is bogus, then die.
        if ( my $nonexistent = first { ! -e $_ } @args ) {
            my $msg = qq{No such file or directory: '$nonexistent'};
            pod2usage( -exitstatus => 1, -message => $msg, -verbose => 0);
        }

        # Reading code from files or dirs.  If argument is a file,
        # then we process it as-is (even though it may not actually
        # be Perl code).  If argument is a directory, recursively
        # search the directory for files that look like Perl code.
        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";

    # Perl::Critic has lots of dependencies, so loading is delayed
    # until it is really needed.  This hack reduces startup time for
    # doing other things like getting the version number or dumping
    # the man page. Arguably, those things are pretty rare, but hey,
    # why not save a few seconds if you can.

    require Perl::Critic;
    $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) {
                # P::C::Exception::Fatal includes the stack trace in its
                # stringification.
                die qq<Fatal error while critiquing "$file": $EVAL_ERROR\n>;
            }
            else {
                die qq<Fatal error while critiquing "$file". Unfortunately, >,
                    q<$@/$EVAL_ERROR >, ## no critic (RequireInterpolationOfMetachars)
                    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 ) = @_;

    # Only report the files, if asked.
    my $number_of_violations = scalar @violations;
    if ( $opts_ref->{'-files-with-violations'} ||
        $opts_ref->{'-files-without-violations'} ) {
        not ref $file
            and $opts_ref->{$number_of_violations ? '-files-with-violations' :
            '-files-without-violations'}
            and _out "$file\n";
        return $number_of_violations;
    }

    # Only report the number of violations, if asked.
    if( $opts_ref->{-count} ){
        ref $file || _out "$file: ";
        _out "$number_of_violations\n";
        return $number_of_violations;
    }

    # Hail all-clear unless we should shut up.
    if( !@violations && !$opts_ref->{-quiet} ) {
        ref $file || _out "$file ";
        _out "source OK\n";
        return 0;
    }

    # Otherwise, format and print violations
    my $verbosity = $critic->config->verbose();
    # $verbosity can be numeric or string, so use "eq" for comparison;
    $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; } #HACK!
    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  ## no critic (InputOutput::RequireBriefOpen)
        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"; # There's prior output that we want to separate from.
    }

    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;

    _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';

    my $lines_of_blank = _commaify( $statistics->lines_of_blank() );
    my $lines_of_comment = _commaify( $statistics->lines_of_comment() );
    my $lines_of_data = _commaify( $statistics->lines_of_data() );
    my $lines_of_perl = _commaify( $statistics->lines_of_perl() );
    my $lines_of_pod = _commaify( $statistics->lines_of_pod() );

    $width =
        max map { length }
            $lines_of_blank, $lines_of_comment, $lines_of_data,
            $lines_of_perl,  $lines_of_pod;
    _out sprintf "\n%s %s:\n",            $lines, 'lines, consisting of';
    _out sprintf "    %*s %s.\n", $width, $lines_of_blank, 'blank lines';
    _out sprintf "    %*s %s.\n", $width, $lines_of_comment, 'comment lines';
    _out sprintf "    %*s %s.\n", $width, $lines_of_data, 'data lines';
    _out sprintf "    %*s %s.\n", $width, $lines_of_perl, 'lines of Perl code';
    _out sprintf "    %*s %s.\n", $width, $lines_of_pod, 'lines of POD';

    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;
}

#-----------------------------------------------------------------------------

# Only works for integers.
sub _commaify {
    my ( $number ) = @_;

    while ($number =~ s/ \A ( [-+]? \d+ ) ( \d{3} ) /$1,$2/xms) {
        # nothing
    }

    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-enabled
        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
        allow-unsafe
        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
        files-with-violations|l
        files-without-violations|L
        program-extensions=s@
    >;
}

#-----------------------------------------------------------------------------

sub _colorize_by_severity {
    my @violations = @_;
    return @violations if _this_is_windows();
    return @violations if not eval {
        require Term::ANSIColor;
        Term::ANSIColor->VERSION( $_MODULE_VERSION_TERM_ANSICOLOR );
        1;
    };

    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;
    # $terminator is a purely cosmetic change to make the color end at the end
    # of the line rather than right before the next line. It is here because
    # if you use background colors, some console windows display a little
    # fragment of colored background before the next uncolored (or
    # differently-colored) line.
    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; ## no critic (ProhibitInteractiveTest);
}

#-----------------------------------------------------------------------------

sub _render_all_policy_listing {
    # Force P-C parameters, to catch all Policies on this site
    my %pc_params = (-profile => $EMPTY, -severity => $SEVERITY_LOWEST);
    return _render_policy_listing( %pc_params );
}

#-----------------------------------------------------------------------------

sub _render_policy_listing {
    my %pc_params = @_;

    require Perl::Critic::PolicyListing;
    require Perl::Critic;

    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 {

    require Perl::Critic::ThemeListing;
    require Perl::Critic;

    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 {

    require Perl::Critic::ProfilePrototype;
    require Perl::Critic;

    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};

    require Perl::Critic;
    $critic = Perl::Critic->new(%opts);
    _set_up_pager($critic->config()->pager());

    require Perl::Critic::PolicyFactory;
    my @site_policies  = Perl::Critic::PolicyFactory->site_policy_names();
    my @matching_policies  = grep { $_ =~ m/$pattern/ixms } @site_policies;

    # "-T" means don't send to pager
    my @perldoc_output = map {`perldoc -T $_`} @matching_policies;  ## no critic (ProhibitBacktick)
    _out @perldoc_output;

    exit $EXIT_SUCCESS;
}

#-----------------------------------------------------------------------------

sub _display_version {
    _out "$VERSION\n";
    exit $EXIT_SUCCESS;
}

#-----------------------------------------------------------------------------
1;

__END__

#-----------------------------------------------------------------------------


##############################################################################
# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 78
#   indent-tabs-mode: nil
#   c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :