File Coverage

blib/lib/Module/Checkstyle.pm

Criterion	Covered	Total	%
statement	129	139	92.8
branch	44	52	84.6
condition	3	5	60.0
subroutine	21	21	100.0
pod	4	4	100.0
total	201	221	90.9

package Module::Checkstyle;

use warnings;
use strict;
use Carp;

use PPI;
use File::HomeDir qw(home);
use File::Spec::Functions qw(catfile rel2abs);
use File::Find::Rule;
use List::Util qw(first);
use Module::Pluggable search_path => [qw(Module::Checkstyle::Check)], require => 1;

use Module::Checkstyle::Config;
use Module::Checkstyle::Util qw(:problem);

our $VERSION = "0.04";

# Controls if we want to be more verbose
our $debug = 0;

sub new {
    my ($class, $config) = @_;

    # Standard remake ref to name for pre 5.8 Perls
    $class = ref $class || $class;

    # Load config from ~/.module-checkstyle/config or supplied file
    $config = Module::Checkstyle::Config->new($config);

    if ($debug) {
        if ($config->get_directive('_', '_config-path')) {
            print STDERR "Using configuration from: ", $config->get_directive('_', '_config-path'), "\n";
        }
    }

    my $self = bless {
                      config   => $config,
                      checked  => {},
                      problems => [],
                      handlers => {},
                  }, $class;

    # Config file determines what checks to enable by declaring them as
    my %enable_plugin = map { $_ => 1 } $config->get_enabled_sections();
    my @plugins = Module::Checkstyle->plugins;
    foreach my $plugin_class (@plugins) {
        my $name = $plugin_class;
        $name =~ s/^Module::Checkstyle::Check:://;
        if ($enable_plugin{$name}) {
            my %event = $plugin_class->register();
            if (%event) {
                my $plugin = $plugin_class->new($config);
                while (my ($event, $handler) = each %event) {
                    push @{$self->{handlers}->{$event}}, [$plugin, $handler];
                }
            }
        }
    }

    return $self;
}

sub _check_file {
    my ($self, $file) = @_;

    # Check for perl in shebang
    if ($file !~ /\.(?:pm|pl)$/i) {
        my $skip = 0;
        eval {
            open my $fh, "<", $file || die $!;
            my $shebang = <$fh>;

            if (defined $shebang) {
                chomp $shebang;
                $skip = 1 if $shebang !~ /^\#\!.*perl/;
            }
            else {
                $skip = 1;
            }

            close($fh);
        };
        return if $skip;

        if ($@) {
            push @{$self->{problems}}, make_problem('error',
                                                    $@,
                                                    undef,
                                                    $file);
            return;
        }
    }

    my $document = PPI::Document->new($file);

    if (!$document) {
        push @{$self->{problems}},  make_problem('error',
                                                 PPI::Document->errstr,
                                                 undef,
                                                 $file);
        return;
    }

    # Do all the checking
    $document->index_locations();
    $self->_traverse_element($document, $file);

    1;
}

# The following who declarations (@exlude) and (@include) are copied from AnnoCPAN
# by Ivan Tubert-Brohman [e-mail]

# default files to ignore
my @excludes = (
               qr(/inc/),      # used by Module::Install bundles
               qr(/t/),
               qr(/eg/),
               qr(/blib/),
               qr(/pm_to_blib),
               qr(/?Makefile(.PL)?$),
               qr(/Build.PL$),
               qr(/MANIFEST$)i,
               qr(/README$)i,
               qr(/Changes$)i,
               qr(/ChangeLog$)i,
               qr(/LICENSE$)i,
               qr(/TODO$)i,
               qr(/AUTHORS?$)i,
               qr(/CVS/\w+$),
               qr(/.svn/),
               qr(~$), # backup files
               qr(/\#.*\#$), # backup files
              );

# default files to include
my @includes = (
               qr{.(pm|pl)$}i,
               qr{/[^./]+$},       # files with no extension (typically scripts)
              );

sub _any_match {
    my ($value, $list) = @_;

    if (first { $value =~ $_ } @$list) {
        return 1;
    }

    return 0;
}

sub _get_files {
    my ($dir, $ignore_common) = @_;

    my @files = File::Find::Rule->file()->ascii()->in($dir);

    @files = map { rel2abs($_) } @files;

    if ($ignore_common) {
        @files = grep { _any_match($_, \@includes) && $_ } @files;
        @files = grep { !_any_match($_, \@excludes) && $_ } @files;
    }

    return @files;
}

sub check {
    my $self = shift;
    my $args = ref $_[-1] eq 'HASH' ? pop : { ignore_common => 1 };

    my @check_files;

  GET_FILES:
    foreach my $file (@_) {
        next GET_FILES if !defined $file;

        if (!-e $file) {
            croak "$file does not exist";
        }

        if (-d $file) {
            # Passing ignore_common => 1 or ommiting it turns on ignoration
            # of common files usually found in distributions such as README,
            # blib/*, inc/*, t/*
            push @check_files, _get_files($file, $args->{ignore_common});
        }
        else {
            push @check_files, $file;
        }
    }

    foreach my $file (@check_files) {
        $self->_check_file($file);
    }

    return scalar @{$self->{problems}};
}

sub _post_event {
    my ($self, $event, @args) = @_;

    if (exists $self->{handlers}->{$event}) {
        my @handlers = @{$self->{handlers}->{$event}};
        if (@handlers) {
            foreach my $handler (@handlers) {
                my ($object, $callback) = @$handler;
                eval {
                    my @problems = $callback->($object, @args);
                    push @{$self->{problems}}, @problems;
                };
                if ($@) {
                    croak $@;
                }
            }
        }
    }
}

sub _traverse_element {
    my ($self, $element, $file) = @_;

    my $event = ref $element;
    my $post_leave = 0;
    if ($element->isa('PPI::Node')) {
        $self->_post_event("enter $event", $element, $file);
        $post_leave = 1;
    }

    $self->_post_event($event, $element, $file);

    if ($element->isa('PPI::Node')) {
        foreach my $child ($element->children) {
            $self->_traverse_element($child, $file);
        }
    }

    if ($post_leave) {
        $self->_post_event("leave $event", $element, $file);
    }
}

sub flush_problems {
    my ($self) = @_;
    my $problems = $self->{problems};
    $self->{problems} = [];
    return wantarray ? @$problems : $problems;
}

sub get_problems {
    my ($self) = @_;
    return wantarray ? @{$self->{problems}} : $self->{problems};
}

1;
__END__