From cc4a5b461207728bb8d5f94cd816ad69729630de Mon Sep 17 00:00:00 2001 From: Paul Salcido Date: Sat, 2 Nov 2013 15:03:20 -0400 Subject: [PATCH 1/5] Remove %_Test global, set to $self->{Tests} This allows for Moose::Role, or other such behavior, to override either a) the instances of this class, or b) class behavior via Moose::Meta::Class->create. This should also help eliminate the 'internals broken problem' that can occur during some inheritance paths. --- lib/Test/Class.pm | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/lib/Test/Class.pm b/lib/Test/Class.pm index 03cdf18..582c007 100644 --- a/lib/Test/Class.pm +++ b/lib/Test/Class.pm @@ -39,16 +39,9 @@ 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 { @@ -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); }; From bcb91f89ba5c5461c210fbd19489fd2123eba9bc Mon Sep 17 00:00:00 2001 From: Paul Salcido Date: Sat, 2 Nov 2013 15:18:47 -0400 Subject: [PATCH 2/5] Subroutines should be methods when they can Allow sub classes and roles to override the way that Test::Class works should someone need to do so. Modifying behavior (additional logging, etc), should be easy and not require the modification of Test::Class to be able to do it. --- lib/Test/Class.pm | 72 +++++++++++++++++++++++------------------------ 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/lib/Test/Class.pm b/lib/Test/Class.pm index 582c007..b819aed 100644 --- a/lib/Test/Class.pm +++ b/lib/Test/Class.pm @@ -46,12 +46,12 @@ sub _test_info { 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} }; @@ -80,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; } @@ -138,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 ) { @@ -167,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); }; @@ -205,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); @@ -244,9 +244,9 @@ sub _exception_failure { 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; @@ -258,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; @@ -284,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; @@ -295,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 { @@ -308,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 } @@ -352,7 +352,7 @@ 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) { @@ -361,38 +361,38 @@ sub runtests { 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); + my @test_methods = $t->_get_methods(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); + 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; next TEST_OBJECT unless $method_passed; }; my $class = ref($t); - my @setup = _get_methods($t, SETUP); - my @teardown = _get_methods($t, TEARDOWN); + 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 ) { - _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); + $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 (_get_methods($t, SHUTDOWN)) { - _show_header($t, @tests) unless _has_no_tests($t, $method); - $all_passed = 0 unless _run_method($t, $method, \@tests); + 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); } } @@ -412,9 +412,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 ); From 738725f19ab4f9c3fc6eed24df5e03f560e920a6 Mon Sep 17 00:00:00 2001 From: Paul Salcido Date: Sat, 2 Nov 2013 16:13:19 -0400 Subject: [PATCH 3/5] Tests using Moose::Role. Demonstrate a few benefits of the changes. --- Build.PL | 3 ++ t/moose_roles.t | 78 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 81 insertions(+) create mode 100644 t/moose_roles.t diff --git a/Build.PL b/Build.PL index 1687304..57630e5 100644 --- a/Build.PL +++ b/Build.PL @@ -13,6 +13,9 @@ my $build = Module::Build->new( 'Test::Builder::Tester' => '1.02', 'Test::More' => '0.78', }, + test_requires => { + 'Moose' => '2.04', + }, build_requires => { 'Test::Exception' => '0.25', 'IO::File' => '1.09', diff --git a/t/moose_roles.t b/t/moose_roles.t new file mode 100644 index 0000000..03fb111 --- /dev/null +++ b/t/moose_roles.t @@ -0,0 +1,78 @@ +#! /usr/bin/perl -T + +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+1); +}; + +package main; + +use strict; +use warnings; + +use Test::More tests => 15; + +use Moose::Meta::Class; +use Moose::Util qw(apply_all_roles); + +my $test = My::Test::Class->new; + +apply_all_roles($test,'My::Test::Class::Role'); + +eval { + $test->runtests; +}; + +ok(!$@, "Eval should return cleanly with Moose::Role application"); +is($test->method_info_called,8,"_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"); +is($test->method_info_called,8,"_method_info called count is correct"); + +done_testing(); From 375e3158a07125271852cbe2dae76b336c35dcce Mon Sep 17 00:00:00 2001 From: Paul Salcido Date: Fri, 15 Nov 2013 11:25:12 -0800 Subject: [PATCH 4/5] Remove Moose dependency in test. --- Build.PL | 3 -- t/moose_roles.t | 62 +++++++++----------------- t/test-libs/lib-moose/My/Test/Class.pm | 36 +++++++++++++++ 3 files changed, 56 insertions(+), 45 deletions(-) create mode 100644 t/test-libs/lib-moose/My/Test/Class.pm diff --git a/Build.PL b/Build.PL index 57630e5..1687304 100644 --- a/Build.PL +++ b/Build.PL @@ -13,9 +13,6 @@ my $build = Module::Build->new( 'Test::Builder::Tester' => '1.02', 'Test::More' => '0.78', }, - test_requires => { - 'Moose' => '2.04', - }, build_requires => { 'Test::Exception' => '0.25', 'IO::File' => '1.09', diff --git a/t/moose_roles.t b/t/moose_roles.t index 03fb111..59ae345 100644 --- a/t/moose_roles.t +++ b/t/moose_roles.t @@ -1,60 +1,37 @@ #! /usr/bin/perl -T - -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+1); -}; - package main; use strict; use warnings; -use Test::More tests => 15; +use Test::More; -use Moose::Meta::Class; -use Moose::Util qw(apply_all_roles); +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; -apply_all_roles($test,'My::Test::Class::Role'); +Moose::Util::apply_all_roles($test,'My::Test::Class::Role'); eval { $test->runtests; }; ok(!$@, "Eval should return cleanly with Moose::Role application"); -is($test->method_info_called,8,"_method_info called count is correct"); +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', @@ -73,6 +50,7 @@ eval { }; ok(!$@, "Eval should return cleanly with Moose::Role application"); -is($test->method_info_called,8,"_method_info called count is correct"); +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; From 8f9fd2f4ca222f37f99747fa2b828840559f6c53 Mon Sep 17 00:00:00 2001 From: Paul Salcido Date: Fri, 15 Nov 2013 12:12:08 -0800 Subject: [PATCH 5/5] Separate running tests per class into own method This modification allows someone trying to add debugging on a per class basis, or to override behavior in various ways that I might not be able to anticipate. --- lib/Test/Class.pm | 71 +++++++++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 33 deletions(-) diff --git a/lib/Test/Class.pm b/lib/Test/Class.pm index b819aed..393c3fc 100644 --- a/lib/Test/Class.pm +++ b/lib/Test/Class.pm @@ -240,7 +240,7 @@ 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; @@ -355,7 +355,7 @@ sub runtests { @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" @@ -365,42 +365,47 @@ sub runtests { $Builder->skip( $reason ) unless $reason eq "1"; } else { $t = $t->new unless ref($t); - 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; - next TEST_OBJECT 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); - } - } - + $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)) {