#! perl
# Copyright (C) 2001-2007, The Perl Foundation.
# $Id: perlcritic.t 27018 2008-04-17 14:45:47Z coke $

use strict;
use warnings;

use lib qw(. lib ../lib ../../lib);

use Fatal qw(open);
use File::Find;
use File::Spec;
use Test::More;
use Parrot::Config qw{%PConfig};
use Parrot::Distribution;
use Getopt::Long;

BEGIN {
    eval { require Perl::Critic; };
    if ($@) {
        plan skip_all => 'Perl::Critic not installed';
    }
    my $required_version = 1.03;
    if ( $Perl::Critic::VERSION < $required_version ) {
        plan skip_all => "Perl::Critic v$required_version required, v$Perl::Critic::VERSION found";
    }
}

my $perl_tidy_conf = 'tools/util/perltidy.conf';

my %policies;
my ( $list_policies_flag, $list_files_flag, @input_policies );
my $policy_group = 'default';

GetOptions(
    'list'      => \$list_policies_flag,
    'listfiles' => \$list_files_flag,
    'policy=s'  => \@input_policies,
    'group=s'   => \$policy_group,         # all, default, extra
);

# if we we're given a policy (or policies), set it to the policies hash
# this still doesn't implement passing options to policies though...
# i.e. need to be able to handle --policy=foo=>{'bar'=>baz}
if (@input_policies) {
    foreach my $input_policy (@input_policies) {

        # now split on commas if that's been used as well
        my @sub_policies = split( /,/, $input_policy );
        foreach my $sub_policy (@sub_policies) {
            $policies{$sub_policy} = 1;
        }
    }
}

# get the files to check
my $DIST = Parrot::Distribution->new();
my @files;
if ( !@ARGV ) {

    @files = map { $_->path } $DIST->get_perl_language_files();

    # Skip any language files...
    my $languages_dir = File::Spec->catdir( $PConfig{build_dir}, 'languages' );
    @files = grep { !m{\Q$languages_dir\E} } @files;
}
else {

    # if we're passed a directory, find all the matching files
    # under that directory.

    # use $_ for the check below, as File::Find chdirs on us.
    # RT#44441 Change this to simply return all files in the distribution
    #     from this point down? -Coke
    foreach my $file (@ARGV) {
        ( -d $file )
            ? find(
            sub {
                if ( -d $_ and $_ eq '.svn' ) {
                    $File::Find::prune = 1;
                    return;
                }
                if ( is_perl($_) ) {
                    push @files, $File::Find::name;
                }
            },
            $file
            )
            : push @files, $file;
    }
}

if ($list_files_flag) {
    print "Files to be tested by perlcritic:\n";
    for my $file (@files) {
        print $file, "\n";
    }

    exit;
}

# Add in the few cases we should care about.
# For a list of available policies, perldoc Perl::Critic
if ( keys %policies ) {

    # if the policy is passed in on the command line, and it's one of the
    # ones where we require certain config arguments, then set them to the
    # ones we want here.

    # XXX this information is being duplicated, we should only specify the
    # perltidyrc once, e.g.

    if ( grep /CodeLayout::RequireTidyCode/, @input_policies ) {
        $policies{'CodeLayout::RequireTidyCode'} = { perltidyrc => $perl_tidy_conf };
    }
    elsif ( grep /CodeLayout::ProhibitHardTabs/, @input_policies ) {
        $policies{'CodeLayout::ProhibitHardTabs'} = { allow_leading_tabs => 0 };
    }
}
else {
    # otherwise, just run perlcritic.t normally

    my %default_policies = (
        'BuiltinFunctions::ProhibitStringySplit'          => 1,
        'CodeLayout::ProhibitDuplicateCoda'               => 1,
        'CodeLayout::ProhibitHardTabs'                    => { allow_leading_tabs => 0 },
        'CodeLayout::ProhibitTrailingWhitespace'          => 1,
        'CodeLayout::UseParrotCoda'                       => 1,
        'InputOutput::ProhibitBarewordFileHandles'        => 1,
        'InputOutput::ProhibitTwoArgOpen'                 => 1,
        'Subroutines::ProhibitExplicitReturnUndef'        => 1,
        'Subroutines::ProhibitSubroutinePrototypes'       => 1,
        'TestingAndDebugging::MisplacedShebang'           => 1,
        'TestingAndDebugging::ProhibitShebangWarningsArg' => 1,
        'TestingAndDebugging::RequirePortableShebang'     => 1,
        'TestingAndDebugging::RequireUseStrict'           => 1,
        'TestingAndDebugging::RequireUseWarnings'         => 1,
        'Variables::ProhibitConditionalDeclarations'      => 1,
    );

    # Allow some names normally proscribed by PBP.
    my @ambiguousNames = grep {$_ ne 'abstract'}
        Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames::default_forbidden_words();

    # These policies are not yet passing consistently.
    my %extra_policies = (
        'CodeLayout::RequireTidyCode' =>
            { perltidyrc => $perl_tidy_conf },
        'NamingConventions::ProhibitAmbiguousNames' =>
            { forbid => join(" ", @ambiguousNames)},
        'Subroutines::ProhibitBuiltinHomonyms'      => 1,
        'Subroutines::RequireFinalReturn'           => 1,
    );

    # Add Perl::Critic::Bangs if it exists
    eval { require Perl::Critic::Bangs; };
    if ($@) {
        diag "Perl::Critic::Bangs not installed: not testing for TODO items in code";
    }
    else {
        $default_policies{'Bangs::ProhibitFlagComments'} = 1;
    }

    # decide which policy group to use
    if ( $policy_group eq 'default' ) {
        %policies = %default_policies;
    }
    elsif ( $policy_group eq 'extra' ) {
        %policies = %extra_policies;
    }
    elsif ( $policy_group eq 'all' ) {
        %policies = ( %default_policies, %extra_policies );
    }
    else {
        warn "Unknown policy group, using 'default' policy group";
    }

    # Give a diag to let users know if this is doing anything, how to repeat.
    if (exists $policies{'CodeLayout::RequireTidyCode'}) {
        eval { require Perl::Tidy; };
        if ( !$@ ) {
            diag "Using $perl_tidy_conf for Perl::Tidy settings";
        }
    }
}

if ($list_policies_flag) {
    use Data::Dumper;
    $Data::Dumper::Indent = 1;
    $Data::Dumper::Terse  = 1;
    foreach my $policy ( sort keys %policies ) {
        if ( $policies{$policy} == 1 ) {
            print $policy, "\n";
        }
        else {
            warn $policy, " => ", Dumper( \$policies{$policy} );
        }
    }
    exit;
}

# the number of tests is the number of policies
if ( keys %policies ) {
    plan tests => scalar keys %policies;
}
else {
    exit;
}

# Create a critic object with all of the policies we care about.

# By default, don't complain about anything.
my $config = Perl::Critic::Config->new( -exclude => [qr/.*/] );

foreach my $policy ( keys %policies ) {
    $config->add_policy(
        -policy => $policy,
        ref $policies{$policy} ? ( -config => $policies{$policy} ) : (),
    ) or die;
}

my $critic = Perl::Critic->new(
    -config => $config,
    -top    => 50,
);

$Perl::Critic::Violation::FORMAT = '%f:%l.%c';

my %violations = map { $_, [] } ( keys %policies );

# check each file for the given policies
foreach my $file ( sort @files ) {
    if ( !-r $file ) {
        diag "skipping invalid file: $file\n";
        next;
    }

    foreach my $violation ( $critic->critique($file) ) {
        my $policy = $violation->policy();
        $policy =~ s/^Perl::Critic::Policy:://;
        push @{ $violations{$policy} }, $violation->to_string();
    }
}

foreach my $policy ( sort keys %violations ) {
    my @violations = @{ $violations{$policy} };
    ok( !@violations, $policy )
        or diag( "Policy: $policy failed in "
            . scalar @violations
            . " instances:\n"
            . join( "\n", @violations ) );
}

__END__

=head1 NAME

t/codingstd/perlcritic.t - use perlcritic for perl coding stds.

=head1 SYNOPSIS

 % prove t/codingstd/perlcritic.t

 % perl --policy=TestingAndDebugging::RequireUseWarnings t/codingstd/perlcritic.t

 % perl --group=all t/codingstd/perlcritic.t

 % perl --group=extra t/codingstd/perlcritic.t

=head1 DESCRIPTION

Tests all perl source files for some very specific perl coding violations.

Optionally specify directories or files on the command line to test B<only>
those files, otherwise all files in the C<MANIFEST> will be checked.

By default, this script will validate the specified files against a default
set of policies. To run the test for a B<specific> Rule, specify it on the
command line before any other files, as:

 perl t/codingstd/perlcritic.t --policy=TestingAndDebugging::RequireUseWarnings

This will, for example, use B<only> that policy (see L<Perl::Critic> for
more information on policies) when examining files from the manifest.

Multiple policies can be specified either by separating the individual
policies with a comma:

 --policy=foo,bar

and/or by specifying the C<--policy> argument multiple times on the command
line.

If you just wish to get a listing of the polices that will be checked
without actually running them, use:

 perl t/codingstd/perlcritic.t --list

If you just wish to get a listing of the files that will be checked
without actually running the tests, use:

 perl t/codingstd/perlcritic.t --listfiles

Not all policies are analysed by default.  To process the extra policies,
use the C<--group=extra> argument.  To process all policies use:

 perl t/codingstd/perlcritic.t --group=all

=head1 BUGS AND LIMITATIONS

There's no way to specify options to policies when they are specified on the
command line.

=cut

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
