diff --git a/lib/Test/Class.pm b/lib/Test/Class.pm index 03cdf18..393c3fc 100644 --- a/lib/Test/Class.pm +++ b/lib/Test/Class.pm @@ -39,26 +39,19 @@ my $Tests = {}; my @Filters = (); -my %_Test; # inside-out object field indexed on $self - -sub DESTROY { - my $self = shift; - delete $_Test{ $self }; -}; - sub _test_info { my $self = shift; - return ref($self) ? $_Test{$self} : $Tests; + return ref($self) ? $self->{Tests} : $Tests; }; sub _method_info { my ($self, $class, $method) = @_; - return( _test_info($self)->{$class}->{$method} ); + return( $self->_test_info->{$class}->{$method} ); }; sub _methods_of_class { my ( $self, $class ) = @_; - my $test_info = _test_info($self) + my $test_info = $self->_test_info or die "Test::Class internals seem confused. Did you override " . "new() in a sub-class or via multiple inheritence?\n"; return values %{ $test_info->{$class} }; @@ -87,7 +80,7 @@ sub _is_public_method { shift @parents; foreach my $parent_class ( @parents ) { return unless $parent_class->can( $name ); - return if _method_info( $class, $parent_class, $name ); + return if $class->_method_info($parent_class, $name ); } return 1; } @@ -130,7 +123,7 @@ sub new { my $class = _class_of( $proto ); $proto = {} unless ref($proto); my $self = bless {%$proto, @_}, $class; - $_Test{$self} = dclone($Tests); + $self->{Tests} = dclone($Tests); return($self); }; @@ -145,7 +138,7 @@ sub _get_methods { my %methods = (); foreach my $class ( @{mro::get_linear_isa( $test_class )} ) { FILTER: - foreach my $info ( _methods_of_class( $self, $class ) ) { + foreach my $info ( $self->_methods_of_class($class) ) { my $name = $info->name; if ( $info->type eq TEST ) { @@ -174,17 +167,17 @@ sub _num_expected_tests { if (my $reason = $self->SKIP_CLASS ) { return $reason eq "1" ? 0 : 1; }; - my @test_methods = _get_methods($self, TEST); + my @test_methods = $self->_get_methods(TEST); return 0 unless @test_methods; my @startup_shutdown_methods = - _get_methods($self, STARTUP, SHUTDOWN); + $self->_get_methods(STARTUP, SHUTDOWN); my $num_startup_shutdown_methods = - _total_num_tests($self, @startup_shutdown_methods); + $self->_total_num_tests(@startup_shutdown_methods); return(NO_PLAN) if $num_startup_shutdown_methods eq NO_PLAN; - my @fixture_methods = _get_methods($self, SETUP, TEARDOWN); - my $num_fixture_tests = _total_num_tests($self, @fixture_methods); + my @fixture_methods = $self->_get_methods(SETUP, TEARDOWN); + my $num_fixture_tests = $self->_total_num_tests(@fixture_methods); return(NO_PLAN) if $num_fixture_tests eq NO_PLAN; - my $num_tests = _total_num_tests($self, @test_methods); + my $num_tests = $self->_total_num_tests(@test_methods); return(NO_PLAN) if $num_tests eq NO_PLAN; return($num_startup_shutdown_methods + $num_tests + @test_methods * $num_fixture_tests); }; @@ -212,7 +205,7 @@ sub _total_num_tests { my $total_num_tests = 0; foreach my $method (@methods) { foreach my $class (@{mro::get_linear_isa($class)}) { - my $info = _method_info($self, $class, $method); + my $info = $self->_method_info($class, $method); next unless $info; my $num_tests = $info->num_tests; return(NO_PLAN) if ($num_tests eq NO_PLAN); @@ -247,13 +240,13 @@ sub _all_ok_from { sub _exception_failure { my ($self, $method, $exception, $tests) = @_; - local $Test::Builder::Level = 3; + local $Test::Builder::Level = 4; my $message = $method; $message .= " (for test method '$Current_method')" if defined $Current_method && $method ne $Current_method; - _show_header($self, @$tests); + $self->_show_header(@$tests); $Builder->ok(0, "$message died ($exception)"); - _threw_exception( $self, $method => 1 ); + $self->_threw_exception($method => 1); }; my %threw_exception; @@ -265,9 +258,9 @@ sub _threw_exception { return $threw_exception{ $class }{ $method }; } -sub _run_method { +sub run_method { my ($self, $method, $tests) = @_; - _threw_exception( $self, $method => 0 ); + $self->_threw_exception($method => 0 ); my $num_start = $Builder->current_test; my $skip_reason; my $original_ok = \&Test::Builder::ok; @@ -291,10 +284,10 @@ sub _run_method { my $exception = $@; chomp($exception) if $exception; my $num_done = $Builder->current_test - $num_start; - my $num_expected = _total_num_tests($self, $method); + my $num_expected = $self->_total_num_tests($method); $num_expected = $num_done if $num_expected eq NO_PLAN; if ($num_done == $num_expected) { - _exception_failure($self, $method, $exception, $tests) + $self->_exception_failure($method, $exception, $tests) unless $exception eq ''; } elsif ($num_done > $num_expected) { my $class = ref $self; @@ -302,7 +295,7 @@ sub _run_method { } else { until (($Builder->current_test - $num_start) >= $num_expected) { if ($exception ne '') { - _exception_failure($self, $method, $exception, $tests); + $self->_exception_failure($method, $exception, $tests); $skip_reason = "$method died"; $exception = ''; } else { @@ -315,7 +308,7 @@ sub _run_method { }; }; }; - return(_all_ok_from($self, $num_start)); + return($self->_all_ok_from($num_start)); }; sub fail_if_returned_early { 0 } @@ -359,55 +352,60 @@ sub runtests { my @tests = @_; if (@tests == 1 && !ref($tests[0])) { my $base_class = shift @tests; - @tests = _test_classes( $base_class ); + @tests = $base_class->_test_classes; }; my $all_passed = 1; - TEST_OBJECT: foreach my $t (@tests) { + foreach my $t (@tests) { # SHOULD ALSO ALLOW NO_PLAN next if $t =~ m/^\d+$/; croak "$t is not Test::Class or integer" unless _isa_class( __PACKAGE__, $t ); if (my $reason = $t->SKIP_CLASS) { - _show_header($t, @tests); + $t->_show_header(@tests); $Builder->skip( $reason ) unless $reason eq "1"; } else { $t = $t->new unless ref($t); - my @test_methods = _get_methods($t, TEST); - if ( @test_methods ) { - foreach my $method (_get_methods($t, STARTUP)) { - _show_header($t, @tests) unless _has_no_tests($t, $method); - my $method_passed = _run_method($t, $method, \@tests); - $all_passed = 0 unless $method_passed; - next TEST_OBJECT unless $method_passed; - }; - my $class = ref($t); - my @setup = _get_methods($t, SETUP); - my @teardown = _get_methods($t, TEARDOWN); - foreach my $test ( @test_methods ) { - local $Current_method = $test; - $Builder->diag("\n$class->$test") if $ENV{TEST_VERBOSE}; - my @methods_to_run = (@setup, $test, @teardown); - while ( my $method = shift @methods_to_run ) { - _show_header($t, @tests) unless _has_no_tests($t, $method); - $all_passed = 0 unless _run_method($t, $method, \@tests); - if ( _threw_exception( $t, $method ) ) { - my $num_to_skip = _total_num_tests($t, @methods_to_run); - $Builder->skip( "$method died" ) for ( 1 .. $num_to_skip ); - last; - }; - }; - }; - foreach my $method (_get_methods($t, SHUTDOWN)) { - _show_header($t, @tests) unless _has_no_tests($t, $method); - $all_passed = 0 unless _run_method($t, $method, \@tests); - } - } - + $all_passed = $t->run_class_tests($all_passed,\@tests); } } return($all_passed); }; +sub run_class_tests { + my ($t,$all_passed,$tests) = @_; + my @test_methods = $t->_get_methods(TEST); + if ( @test_methods ) { + foreach my $method ($t->_get_methods(STARTUP)) { + $t->_show_header(@$tests) unless $t->_has_no_tests($method); + my $method_passed = $t->run_method($method, $tests); + $all_passed = 0 unless $method_passed; + return $all_passed unless $method_passed; + }; + my $class = ref($t); + my @setup = $t->_get_methods(SETUP); + my @teardown = $t->_get_methods(TEARDOWN); + foreach my $test ( @test_methods ) { + local $Current_method = $test; + $Builder->diag("\n$class->$test") if $ENV{TEST_VERBOSE}; + my @methods_to_run = (@setup, $test, @teardown); + while ( my $method = shift @methods_to_run ) { + $t->_show_header(@$tests) unless $t->_has_no_tests($method); + $all_passed = 0 unless $t->run_method($method, $tests); + if ( $t->_threw_exception($method ) ) { + my $num_to_skip = $t->_total_num_tests(@methods_to_run); + $Builder->skip( "$method died" ) for ( 1 .. $num_to_skip ); + last; + }; + }; + }; + foreach my $method ($t->_get_methods(SHUTDOWN)) { + $t->_show_header(@$tests) unless $t->_has_no_tests($method); + $all_passed = 0 unless $t->run_method($method, $tests); + } + } + return $all_passed; +} + sub _find_calling_test_class { my $level = 0; while (my $class = caller(++$level)) { @@ -419,9 +417,9 @@ sub _find_calling_test_class { sub num_method_tests { my ($self, $method, $n) = @_; - my $class = _find_calling_test_class( $self ) + my $class = $self->_find_calling_test_class or croak "not called in a Test::Class"; - my $info = _method_info($self, $class, $method) + my $info = $self->_method_info($class, $method) or croak "$method is not a test method of class $class"; $info->num_tests($n) if defined($n); return( $info->num_tests ); diff --git a/t/moose_roles.t b/t/moose_roles.t new file mode 100644 index 0000000..59ae345 --- /dev/null +++ b/t/moose_roles.t @@ -0,0 +1,56 @@ +#! /usr/bin/perl -T +package main; + +use strict; +use warnings; + +use Test::More; + +BEGIN { + no warnings; + eval "use Moose"; + if ($@ ) { + plan skip_all => "need Moose" if $@; + } else { + plan tests => 21; + use_ok 'Test::Class'; + use lib qw(t/test-libs/lib-moose); + use_ok 'My::Test::Class'; + use_ok 'Moose::Meta::Class'; + use_ok 'Moose::Util'; + } +} + +my $test = My::Test::Class->new; + +Moose::Util::apply_all_roles($test,'My::Test::Class::Role'); + +eval { + $test->runtests; +}; + +ok(!$@, "Eval should return cleanly with Moose::Role application"); +ok(defined $test->method_info_called,"_method_info_called is defined"); +ok($test->method_info_called > 0,"_method_info called count is correct"); + +my $new_package = Moose::Meta::Class->create( + 'My::Test::Class::MethodCallCounts', + superclasses => ['My::Test::Class'], + roles => [ + 'My::Test::Class::Role', + ], +)->name; + +isa_ok($new_package, 'My::Test::Class::MethodCallCounts'); +isa_ok($new_package, 'My::Test::Class'); +isa_ok($new_package, 'Test::Class'); + +eval { + $new_package->runtests; +}; + +ok(!$@, "Eval should return cleanly with Moose::Role application"); +ok(defined $test->method_info_called,"_method_info_called is defined"); +ok($test->method_info_called > 0,"_method_info called count is correct"); + +done_testing(); diff --git a/t/test-libs/lib-moose/My/Test/Class.pm b/t/test-libs/lib-moose/My/Test/Class.pm new file mode 100644 index 0000000..9662189 --- /dev/null +++ b/t/test-libs/lib-moose/My/Test/Class.pm @@ -0,0 +1,36 @@ +package My::Test::Class; + +use base qw(Test::Class); + +use Test::More; + +sub test_1 :Test(2) { + my $self = shift; + + ok(1); + ok(1); +} + +sub test_2 :Test(2) { + my $self = shift; + + ok(1); + ok(1); +} + +package My::Test::Class::Role; + +use Moose::Role; + +has 'method_info_called' => ( + is => 'rw', + isa => 'Int', + default => 0, +); + +after '_method_info' => sub { + my $self = shift; + $self->method_info_called( ( $self->method_info_called || 0) + 1); +}; + +1;