File Coverage

blib/lib/Test/AllModules.pm

Criterion	Covered	Total	%
statement	112	122	91.8
branch	47	58	81.0
condition	10	18	55.5
subroutine	17	17	100.0
pod	1	1	100.0
total	187	216	86.5

package Test::AllModules;
use strict;
use warnings;
use Module::Pluggable::Object;
use Test::More ();

our $VERSION = '0.17';

my $USE_OK = sub {
    eval "use $_[0];"; ## no critic
    if (my $e = $@) {
        Test::More::note($e);
        return;
    }
    return 1;
};
my $USE_NO_IMPORT_OK = sub {
    eval "use $_[0] qw//;"; ## no critic
    if (my $e = $@) {
        Test::More::note($e);
        return;
    }
    return 1;
};


my $REQUIRE_OK = sub {
    eval "require $_[0];"; ## no critic
    if (my $e = $@) {
        Test::More::note($e);
        return;
    }
    return 1;
};

sub import {
    my $class = shift;

    my $caller = caller;

    no strict 'refs'; ## no critic
    for my $func (qw/ all_ok /) {
        *{"${caller}::$func"} = \&{"Test::AllModules::$func"};
    }
}

sub all_ok {
    my %param = @_;

    my $search_path = delete $param{search_path};
    my $use_ok      = delete $param{use}     || $param{use_ok};
    my $require_ok  = delete $param{require} || $param{require_ok};
    my $check       = delete $param{check};
    my $checks      = delete $param{checks};
    my $except      = delete $param{except};
    my $lib         = delete $param{lib};
    my $fork        = delete $param{fork};
    my $shuffle     = delete $param{shuffle};
    my $show_version = delete $param{show_version};
    my $no_import   = delete $param{no_import};
    my $before_hook = delete $param{before_hook};
    my $after_hook  = delete $param{after_hook};

    if ( _is_win() && $fork ) {
        Test::More::plan skip_all => 'The "fork" option is not supported in Windows';
        exit;
    }

    my @checks;
    push @checks, +{ test => $no_import ? $USE_NO_IMPORT_OK : $USE_OK, name => 'use: ' } if $use_ok;
    push @checks, +{ test => $REQUIRE_OK, name => 'require: ' } if $require_ok;

    if (ref($check) eq 'CODE') {
        push @checks, +{ test => $check, name => '', };
    }
    else {
        for my $code ( $check, @{ $checks || [] } ) {
            my ($name) = keys %{$code || +{}};
            my $test   = $name ? $code->{$name} : undef;
            if (ref($test) eq 'CODE') {
                push @checks, +{ test => $test, name => "$name: ", };
            }
        }
    }

    unless ($search_path) {
        Test::More::plan skip_all => 'no search path';
        exit;
    }

    Test::More::plan('no_plan');
    my @exceptions = @{ $except || [] };

    if ($fork) {
        require Test::SharedFork;
        Test::More::note("Tests run under forking. Parent PID=$$");
    }

    my $count = 0;
    for my $class (
        grep { !_is_excluded( $_, @exceptions ) }
            _classes($search_path, $lib, $shuffle) ) {
        $count++;
        for my $code (@checks) {
            next if $before_hook && $before_hook->($code, $class, $count);
            my $ret = _exec_test($code, $class, $count, $fork, $show_version);
            $after_hook && $after_hook->($ret, $code, $class, $count);
        }

    }

    Test::More::note( "total: $count module". ($count > 1 ? 's' : '') );
}

sub _exec_test {
    my ($code, $class, $count, $fork, $show_version) = @_;

    my $ret;

    unless ($fork) {
        $ret = _ok($code, $class, $count, undef, $show_version);
        return $ret;
    }

    my $pid = fork();
    die 'could not fork' unless defined $pid;

    if ($pid) {
        waitpid($pid, 0);
    }
    else {
        $ret = _ok($code, $class, $count, $fork, $show_version);
        exit;
    }

    return $ret;
}

sub _ok {
    my ($code, $class, $count, $fork, $show_version) = @_;

    my $test_name = "$code->{name}$class". ($fork && $fork == 2 ? "(PID=$$)" : '');

    my $ret;
    eval {
        $ret = $code->{test}->($class, $count);
    };

    if (my $e = $@) {
        Test::More::fail($test_name);
        Test::More::note("The Test failed: $e");
        return;
    }

    if ( Test::More::ok($ret, $test_name) ) {
        if ($show_version) {
            no strict 'refs'; ## no critic
            if ( my $version = ${"$class\::VERSION"} ) {
                Test::More::note("$class $version");
            }
        }
        return 1; # ok
    }
    else {
        my $got = defined $ret ? $ret : '';
        Test::More::note("The Test did NOT return true value. got: $got");
    }

    return;
}

sub _classes {
    my ($search_path, $lib, $shuffle) = @_;

    local @INC = @{ $lib || ['lib'] };
    my $finder = Module::Pluggable::Object->new(
        search_path => $search_path,
    );
    my @classes = ( $search_path, $finder->plugins );

    return $shuffle ? _shuffle(@classes) : sort(@classes);
}

# This '_shuffle' method copied
# from http://blog.nomadscafe.jp/archives/000246.html
sub _shuffle {
    map { $_[$_->[0]] } sort { $a->[1] <=> $b->[1] } map { [$_ , rand(1)] } 0..$#_;
}

# This '_any' method copied from List::MoreUtils.
sub _any (&@) { ## no critic
    my $f = shift;

    foreach ( @_ ) {
        return 1 if $f->();
    }
    return;
}

sub _is_excluded {
    my ( $module, @exceptions ) = @_;
    _any { $module eq $_ || $module =~ /$_/ } @exceptions;
}

sub _is_win {
    return ($^O && $^O eq 'MSWin32') ? 1 : 0;
}

1;

__END__