File Coverage

blib/lib/Test/Extreme.pm

Criterion	Covered	Total	%
statement	315	351	89.7
branch	26	36	72.2
condition			n/a
subroutine	54	65	83.0
pod	0	41	0.0
total	395	493	80.1

package Test::Extreme;

use 5.012004;
use strict;
use warnings;

use Carp;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(
    assert
    assert_true
    assert_false
    assert_passed
    assert_failed
    assert_some
    assert_none
    assert_is_array
    assert_equals
    assert_contains
    assert_subset
    assert_is_array
    assert_is_hash
    assert_size
    assert_keys
    assert_is_string
    run_tests
    run_tests_as_script
);

our $VERSION = '1.01';


sub assert($) {
    if ($_[0]) { return; }
    if (defined($@)) { confess "Assertion failed.\n$@"; undef $@; }
    else             { confess "Assertion failed.\n"; }
}

sub assert_true($)  { assert $_[0]    }
sub assert_false($) { assert ! $_[0]  }
sub assert_passed() { assert_false $@ }
sub assert_failed() { assert_true  $@ }
sub assert_some($)  { assert_true  $_[0] }
sub assert_none($)  { assert_false $_[0] }

sub assert_equals_string($$) { assert_true($_[0] eq $_[1]) }

sub assert_is_array($);

sub assert_equals_array($$) {
    my ($list0, $list1) = @_;
    assert_is_array $list0;
    assert_is_array $list1;
    assert_equals_string scalar @$list0, scalar @$list1;
    for (my $i = 0 ; $i < @$list0 ; ++$i) {
        assert_equals( $list0->[$i], $list1->[$i] );
    }
}

sub assert_equals_hash($$) {
    my ($hash0, $hash1) = @_;
    assert_equals_string scalar keys %$hash0, scalar keys %$hash1;
    for my $key (keys %{$hash0}) {
        assert_true exists $hash1->{$key};
        assert_equals($hash0->{$key}, $hash1->{$key});
    }
}

sub assert_equals($$) {
    assert_equals_string $_[0], $_[1] if ref $_[0] eq '';
    assert_equals_array  $_[0], $_[1] if ref $_[0] eq 'ARRAY';
    assert_equals_hash   $_[0], $_[1] if ref $_[0] eq 'HASH';
}

sub assert_contains($$) {
    my ($element, $list) = @_;
    assert_equals "", ref $element;
    assert_equals "ARRAY", ref $list;
    eval { assert_true grep { $_ eq $element } @$list } ;
    if ($@) {
        my $list_text = "[" . join(" " => @$list) . "]";
        confess "Did not find $element in $list_text.\n$@" ;
    }
}

sub assert_subset($$) {
    my ($list1, $list2) = @_;
    assert_equals "ARRAY", ref $list1;
    assert_equals "ARRAY", ref $list2;
    for my $element (@$list1)
    { assert_contains $element, $list2 }
}

sub assert_is_array($) { assert_equals 'ARRAY', ref $_[0] }

sub assert_is_hash($)  { assert_equals 'HASH',  ref $_[0] }

sub assert_size($$) {
    my ($size, $array) = @_;
    assert_is_array $array;
    assert_equals $size, scalar @$array
}

sub assert_keys($$) {
    my ($keys, $hash) = @_;
    assert_is_hash  $hash;
    assert_is_array $keys;
    my @actual_keys   = sort keys %{$hash};
    my @expected_keys = sort @$keys;
    assert_equals \@expected_keys, \@actual_keys
}

sub assert_is_string($) {
    my ($string) = @_;
    assert_equals '', ref $string;
    assert ($string =~ /\S/)
}

sub _list_symbols {
    use vars qw /$symbol $sym @sym %sym/;

    my $pkg = shift;
    my $prefix = shift;

    no strict 'refs';
    my  %pkg_keys = %{$pkg};
    use strict;

    my $symbols = [];
    foreach $symbol (keys %pkg_keys) {
        next if $symbol !~ /^[\:\w]+$/s;    # Skip if not-word
        my $symbol_path = $prefix . $pkg . $symbol ;
        # Need this because Perl 5.12 deprecates defined on hash
        if ($prefix eq '%') {
            push @$symbols, $symbol if eval qq[!!($symbol_path)];
        } else {
            push @$symbols, $symbol if eval qq[ defined($symbol_path) ];
        }
    }
    @$symbols = sort @$symbols;
    return $symbols;
}

sub _list_subs($)     { return _list_symbols shift, '&' }

sub _list_packages($) {
    my $list = _list_symbols shift, '%' ;
    @$list = grep { /::$/ } @$list ;
    return $list;
}

sub _list_tests($) {
    my ($pkg) = @_;
    my $list = _list_subs $pkg;
    @$list = map { $pkg . $_ } grep { /^_*[tT]est/ } @$list ;
    return $list;
}

sub _execute_tests($$$) {
    my ($all_tests, $failure_messages, $output) = @_;
    for my $test (@$all_tests) {
        no strict 'refs';
        eval { &{$test} };
        use strict;
        if ($@) {
            print "F" if $output;
            $failure_messages->{$test} = $@;
        }
        else { print "." if $output }
    }
    print "\n" if $output;
}

sub _print_failure_messages($$) {
    my ($all_tests, $failure_messages) = @_;
    for my $test (sort keys %{$failure_messages}) {
        print "$test: $failure_messages->{$test}"
    }
    print "\n";
    my $test_count = scalar @$all_tests;
    my $fail_count = scalar keys %{$failure_messages};
    my $pass_count = $test_count - $fail_count;
    my $test_or_tests = $test_count == 1 ? "test" : "tests";
    if ($fail_count == 0) {
        print "OK ($test_count $test_or_tests)\n"
    }
    else {
        print "Failures!!!\n\n";
        print "Runs: $test_count,  Passes: $pass_count,  Fails: $fail_count\n";
    }
    print "\n";
}

sub run_tests {
    my @pkgs = map { $_ . "::" } ( 'main' , @_);
    my $all_tests = [];
    for my $pkg (@pkgs) { push @$all_tests, @{ _list_tests $pkg }; }

     my $failure_messages = {};
     _execute_tests $all_tests, $failure_messages, 1;
     _print_failure_messages $all_tests, $failure_messages;
}

sub run_tests_as_script {
    my @pkgs = map { $_ . "::" } ( 'main' , @_);
    my $all_tests = [];
    for my $pkg (@pkgs) { push @$all_tests, @{ _list_tests $pkg }; }

     my $failure_messages = {};
     _execute_tests $all_tests, $failure_messages, 0;

    print "1..", scalar @$all_tests, "\n";
    for (my $i = 0 ; $i < @$all_tests ; ++$i) {
        my $test = $all_tests->[$i];
        print "not "
            if exists $failure_messages->{$test};
        print "ok ", 1 + $i;
        print "\n", join "\n" =>
            map { "# " . $_ ; }
            split /\n/, $test . ": " . $failure_messages->{$test}
                if exists $failure_messages->{$test};
        print "\n";
    }
}


#-----------------------------------------------------------------
# TESTS BEGIN
#-----------------------------------------------------------------

sub test_assert_true() {
    eval { assert_true 1 } ; assert_passed ;
    eval { assert_true 0 } ; assert_failed ;
}

sub test_assert_false() {
    eval { assert_false 1 } ; assert_failed ;
    eval { assert_false 0 } ; assert_passed ;
}

sub test_assert_some() {
    eval { assert_some 1 } ; assert_passed ;
    eval { assert_some 0 } ; assert_failed ;
}

sub test_assert_none() {
    eval { assert_none 1 } ; assert_failed ;
    eval { assert_none 0 } ; assert_passed ;
}

sub test_assert_equals() {
    eval { assert_equals 'a', 'a' } ; assert_passed ;
    eval { assert_equals 'a', 'b' } ; assert_failed ;
}

sub test_assert_equals_array() {
    eval { Test::Extreme::assert_equals_array [ 'a', 'b' ], ['a', 'b'] } ; assert_passed ;
    eval { Test::Extreme::assert_equals_array [ 'a', 'b' ], ['b', 'a'] } ; assert_failed ;

    eval { Test::Extreme::assert_equals_array [ 'a' ], ['a', 'a'] } ; assert_failed ;
    eval { Test::Extreme::assert_equals_array [ 'a', 'b' ], ['a'] } ; assert_failed ;

    eval { Test::Extreme::assert_equals_array 'a', [ 'a' ] } ; assert_failed ;
    eval { Test::Extreme::assert_equals_array [ 'a' ], 'a' } ; assert_failed ;
}

sub test_assert_equals_hash() {
    eval { Test::Extreme::assert_equals_hash { k1=>'v1', k2=>'v2' }, { k1=>'v1', k2=>'v2' } } ; assert_passed ;
    eval { Test::Extreme::assert_equals_hash { k1=>'v1', k2=>'v2' }, { k1=>'v1', k2=>'v3' } } ; assert_failed ;

    eval { Test::Extreme::assert_equals_hash { k1=>'v1', k2=>'v2' }, { k1=>'v1' } } ; assert_failed ;

    eval { Test::Extreme::assert_equals_hash { k1=>'v1', k2=>'v2' }, ['a'] } ; assert_failed ;
    eval { Test::Extreme::assert_equals_hash { k1=>'v1', k2=>'v2' },  'a'  } ; assert_failed ;
}

sub test_assert_equals_polymorphic() {
    eval { assert_equals 'a', 'a' } ; assert_passed ;

    eval { assert_equals [ 'a', 'b' ], ['a', 'b'] } ; assert_passed ;
    eval { assert_equals [ 'a', 'b' ], ['b', 'a'] } ; assert_failed ;

    eval { assert_equals { k1 => 'v1', k2 => 'v2' }, { k1 => 'v1', k2 => 'v2' } } ; assert_passed ;
    eval { assert_equals { k1 => 'v1', k2 => 'v2' }, { k1 => 'v1', k2 => 'v3' } } ; assert_failed ;
}

sub test_assert_subset() {
    eval { assert_subset [ 'a' ], ['a', 'b'] } ; assert_passed ;
    eval { assert_subset ['a', 'b'], ['a', 'b', 'c'] } ; assert_passed;
    eval { assert_subset['a', 'b'], ['a', 'b'] } ; assert_passed;

    eval { assert_subset [ 'c' ], ['a', 'b'] } ; assert_failed ;
    eval { assert_subset [ 'a', 'c' ], ['a', 'b', 'd'] } ; assert_failed ;
}

sub test_assert_contains {
    eval { assert_contains 'a', ['a', 'b'] } ; assert_passed ;
    eval { assert_contains 'b', ['a', 'b'] } ; assert_passed ;
    eval { assert_contains 'c', ['a', 'b'] } ; assert_failed ;
    eval { assert_contains  '', ['a', 'b'] } ; assert_failed ;
}

sub test_assert_is_array {
    eval { assert_is_array ['a', 'b'] } ; assert_passed ;
    eval { assert_is_array {'a', 'b'} } ; assert_failed ;
    eval { assert_is_array  'a'       } ; assert_failed ;
}

sub test_assert_is_hash {
    eval { assert_is_hash {'a', 'b'} } ; assert_passed ;
    eval { assert_is_hash ['a', 'b'] } ; assert_failed ;
    eval { assert_is_hash  'a'       } ; assert_failed ;
}

sub test_assert_size {
    eval { assert_size 2, ['a', 'b'] } ; assert_passed ;
    eval { assert_size 1, ['a']      } ; assert_passed ;
    eval { assert_size 0, []         } ; assert_passed ;

    eval { assert_size 2, {'a', 'b'} } ; assert_failed ;
    eval { assert_size 1, 'a'        } ; assert_failed ;
}

sub test_assert_keys {
    eval { assert_keys ['a', 'b'], { a => 1, b => 2 } } ; assert_passed ;
    eval { assert_keys ['b', 'a'], { a => 1, b => 2 } } ; assert_passed ;
    eval { assert_keys ['a'     ], { a => 1, b => 2 } } ; assert_failed ;
    eval { assert_keys ['a', 'b'], { a => 1         } } ; assert_failed ;

    eval { assert_keys ['a'], ['a'] } ; assert_failed ;
    eval { assert_keys  'a' , ['a'] } ; assert_failed ;
    eval { assert_keys ['a'],  'a'  } ; assert_failed ;
}

sub test_assert_is_string {
    eval { assert_is_string  'hello'  } ; assert_passed ;

    eval { assert_is_string ['hello', 'world'] } ; assert_failed ;
    eval { assert_is_string {'hello', 'world'} } ; assert_failed ;
}


package foo ; sub foo_1 { } sub foo_2 { } sub foo_3 { }
package bar ; sub bar_1 { } sub bar_2 { } sub bar_3 { }
package Test::Extreme;

sub test_list_subs {
    assert_equals [ 'foo_1', 'foo_2', 'foo_3' ], Test::Extreme::_list_subs 'main::foo::';
    assert_equals [ 'foo_1', 'foo_2', 'foo_3' ], Test::Extreme::_list_subs 'foo::';
    assert_equals [ 'bar_1', 'bar_2', 'bar_3' ], Test::Extreme::_list_subs 'bar::';
}

sub test_list_packages()
{
    my $packages = Test::Extreme::_list_packages 'main::';
    assert_subset ['foo::', 'bar::'], $packages;
    assert_none grep { ! /::$/ } @$packages;
}

package foo_test ; sub test_1 { } sub test_2 { } sub test_3 { }
package Test::Extreme;

sub test_list_tests() {
    my $list = Test::Extreme::_list_tests 'foo_test::';
    my $expected = [qw( foo_test::test_1  foo_test::test_2  foo_test::test_3 )];
    assert_equals $expected, $list;
}

sub this_will_pass { assert_true 1 }
sub this_will_fail { assert_true 0 }

sub test_execute_tests {
    my $all_tests = ['Test::Extreme::this_will_pass', 'Test::Extreme::this_will_fail'];
    my $failure_messages = { };
    Test::Extreme::_execute_tests $all_tests, $failure_messages, 0;
    assert_keys ['Test::Extreme::this_will_fail'], $failure_messages;
}

run_tests_as_script 'Test::Extreme' if $0 =~ /Extreme.pm$/;

#-----------------------------------------------------------------
# TESTS END
#-----------------------------------------------------------------

1;
__END__