Perl-Critic

 view release on metacpan or  search on metacpan

lib/Perl/Critic/Command.pm  view on Meta::CPAN

=head1 NAME

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


=head1 SYNOPSIS

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

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


=head1 DESCRIPTION

This is the implementation of the L<perlcritic|perlcritic> command.  You can use
this to run the command without going through a command interpreter.


=head1 INTERFACE SUPPORT

lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm  view on Meta::CPAN

    my $dest    = $EMPTY;
    my $stderr  = $EMPTY;


    # Perl::Tidy gets confused if @ARGV has arguments from
    # another program.  Also, we need to override the
    # stdout and stderr redirects that the user may have
    # configured in their .perltidyrc file.
    # Also override -b because we are using dest and source.
    local @ARGV = qw(-nst -nse -nb);

    # Trap Perl::Tidy errors, just in case it dies
    my $eval_worked = eval {

        # Beginning with version 20120619, Perl::Tidy modifies $source. So we
        # make a copy so we can get a good comparison after tidying. Doing an
        # s/// on $source after the fact appears not to work with previous
        # versions of Perl::Tidy.
        my $source_copy = $source;

t/07_command.t  view on Meta::CPAN

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

use Test::More tests => 57;

our $VERSION = '1.156';

use Perl::Critic::TestUtils;
Perl::Critic::TestUtils::assert_version( $VERSION );

local @ARGV = ();
my $message;
my %options = ();

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

local @ARGV = qw(-1 -2 -3 -4 -5);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 1, $message);

local @ARGV = qw(-5 -3 -4 -1 -2);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 1, $message);

local @ARGV = qw();
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, undef, 'no arguments');

local @ARGV = qw(-2 -3 -severity 4);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 4, $message);

local @ARGV = qw(-severity 2 -3 -4);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 2, $message);

local @ARGV = qw(--severity=2 -3 -4);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 2, $message);

local @ARGV = qw(-cruel);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 'cruel', $message);

local @ARGV = qw(-cruel --severity=1 );
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 1, $message);

local @ARGV = qw(-stern --severity=1 -2);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 1, $message);

local @ARGV = qw(-stern -severity 1 -2);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 1, $message);

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

local @ARGV = qw(-top);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 1, $message);
is( $options{-top}, 20, $message);

local @ARGV = qw(-top 10);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 1, $message);
is( $options{-top}, 10, $message);

local @ARGV = qw(-severity 4 -top);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 4, $message);
is( $options{-top}, 20, $message);

local @ARGV = qw(-severity 4 -top 10);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 4, $message);
is( $options{-top}, 10, $message);

local @ARGV = qw(-severity 5 -2 -top 5);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-severity}, 5, $message);
is( $options{-top}, 5, $message);

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

local @ARGV = qw(-noprofile);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-profile}, q{}, $message);

local @ARGV = qw(-profile foo);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-profile}, 'foo', $message);

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

local @ARGV = qw(-single-policy nowarnings);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{'-single-policy'}, 'nowarnings', $message);

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

local @ARGV = qw(-verbose 2);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-verbose}, 2, $message);

local @ARGV = qw(-verbose %l:%c:%m);
%options = Perl::Critic::Command::_get_options();
is( $options{-verbose}, '%l:%c:%m', $message);

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

local @ARGV = qw(-statistics);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-statistics}, 1, $message);

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

local @ARGV = qw(-statistics-only);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{'-statistics-only'}, 1, $message);

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

local @ARGV = qw(-quiet);
$message = "@ARGV";
%options = Perl::Critic::Command::_get_options();
is( $options{-quiet}, 1, $message);


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

local @ARGV = qw(-pager foo);
$message = "@ARGV";
%options = eval { Perl::Critic::Command::_get_options() };
is( $options{-pager}, 'foo', $message );


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

foreach my $severity ([qw{
    -color-severity-highest
    -colour-severity-highest

t/07_command.t  view on Meta::CPAN

    }],
    [qw{
    -color-severity-lowest
    -colour-severity-lowest
    -color-severity-1
    -colour-severity-1
    }],
) {
    my $canonical = $severity->[0];
    foreach my $opt (@{ $severity }) {
        local @ARGV = ($opt => 'cyan');
        $message = "@ARGV";
        %options = eval { Perl::Critic::Command::_get_options() };
        is( $options{$canonical}, 'cyan', $message );
    }
}


#-----------------------------------------------------------------------------
# Intercept pod2usage so we can test invalid options and special switches

{
    no warnings qw(redefine once); ## no critic (ProhibitNoWarnings)
    local *Perl::Critic::Command::pod2usage =
        sub { my %args = @_; confess $args{-message} || q{} };

    local @ARGV = qw( -help );
    eval { Perl::Critic::Command::_get_options() };
    ok( $EVAL_ERROR, '-help option' );

    local @ARGV = qw( -options );
    eval { Perl::Critic::Command::_get_options() };
    ok( $EVAL_ERROR, '-options option' );

    local @ARGV = qw( -man );
    eval { Perl::Critic::Command::_get_options() };
    ok( $EVAL_ERROR, '-man option' );

    local @ARGV = qw( -noprofile -profile foo );
    eval { Perl::Critic::Command::_get_options() };
    like(
        $EVAL_ERROR,
        qr/-noprofile [ ] with [ ] -profile/xms,
        '-noprofile with -profile',
    );

    local @ARGV = qw( -verbose bogus );
    eval { Perl::Critic::Command::_get_options() };
    like(
        $EVAL_ERROR,
        qr/looks [ ] odd/xms,
        'Invalid -verbose option',
    );

    local @ARGV = qw( -top -9 );
    eval { Perl::Critic::Command::_get_options() };
    like(
        $EVAL_ERROR,
        qr/is [ ] negative/xms,
        'Negative -verbose option',
    );

    local @ARGV = qw( -severity 0 );
    eval { Perl::Critic::Command::_get_options() };
    like(
        $EVAL_ERROR,
        qr/out [ ] of [ ] range/xms,
        '-severity too small',
    );

    local @ARGV = qw( -severity 6 );
    eval { Perl::Critic::Command::_get_options() };
    like(
        $EVAL_ERROR,
        qr/out [ ] of [ ] range/xms,
        '-severity too large',
    );
}

# Local Variables:
#   mode: cperl

t/NamingConventions/Capitalization.run.PL  view on Meta::CPAN

}

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

## name Builtin variables and variables in other packages are exempt.
## failures 0
## parms { global_variables => ':all_lower' }
## cut

local $EVAL_ERROR
local @ARGV;
local %INC;
local $Foo::Bar;

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

## name Test customization example in the Capitalization POD passing.
## failures 0
## parms { global_variables => 'G_(?:(?!_)\w)+', global_variable_exemptions => '.*THINGY.*' }
## cut