File: | inc/Test/Class.pm |
Coverage: | 68.3% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | 2 2 2 | 13 4 11 | #line 1 | ||||
2 | 2 2 2 | 24 3 8 | use strict; | ||||
3 | 2 2 2 | 45 4 4 | use warnings; | ||||
4 | use 5.006; | ||||||
5 | |||||||
6 | package Test::Class; | ||||||
7 | |||||||
8 | 2 2 2 | 13 2 13 | use Attribute::Handlers; | ||||
9 | 2 2 2 | 76 4 23 | use Carp; | ||||
10 | 2 2 2 | 21 3 19 | use Class::ISA; | ||||
11 | 2 2 2 | 10 3 18 | use Devel::Symdump; | ||||
12 | 2 2 2 | 74 4 26 | use Storable qw(dclone); | ||||
13 | 2 2 2 | 82 4 23 | use Test::Builder; | ||||
14 | use Test::Class::MethodInfo; | ||||||
15 | |||||||
16 | our $VERSION = '0.30'; | ||||||
17 | |||||||
18 | my $Check_block_has_run; | ||||||
19 | 2 2 2 | 11 2 11 | { | ||||
20 | 2 | 15 | no warnings 'void'; | ||||
21 | CHECK { $Check_block_has_run = 1 }; | ||||||
22 | } | ||||||
23 | |||||||
24 | 2 2 2 | 11 2 9 | use constant NO_PLAN => "no_plan"; | ||||
25 | 2 2 2 | 11 4 8 | use constant SETUP => "setup"; | ||||
26 | 2 2 2 | 10 4 18 | use constant TEST => "test"; | ||||
27 | 2 2 2 | 11 3 9 | use constant TEARDOWN => "teardown"; | ||||
28 | 2 2 2 | 11 2 8 | use constant STARTUP => "startup"; | ||||
29 | use constant SHUTDOWN => "shutdown"; | ||||||
30 | |||||||
31 | |||||||
32 | 254 | 591 | our $Current_method = undef; | ||||
33 | sub current_method { $Current_method }; | ||||||
34 | |||||||
35 | |||||||
36 | 0 | 0 | my $Builder = Test::Builder->new; | ||||
37 | sub builder { $Builder }; | ||||||
38 | |||||||
39 | |||||||
40 | my $Tests = {}; | ||||||
41 | |||||||
42 | |||||||
43 | my %_Test; # inside-out object field indexed on $self | ||||||
44 | |||||||
45 | 2 | 4 | sub DESTROY { | ||||
46 | 2 | 239 | my $self = shift; | ||||
47 | delete $_Test{ $self }; | ||||||
48 | }; | ||||||
49 | |||||||
50 | 237 | 298 | sub _test_info { | ||||
51 | 237 | 1832 | my $self = shift; | ||||
52 | return ref($self) ? $_Test{$self} : $Tests; | ||||||
53 | }; | ||||||
54 | |||||||
55 | 199 | 405 | sub _method_info { | ||||
56 | 199 | 359 | my ($self, $class, $method) = @_; | ||||
57 | return( _test_info($self)->{$class}->{$method} ); | ||||||
58 | }; | ||||||
59 | |||||||
60 | 38 | 62 | sub _methods_of_class { | ||||
61 | 38 | 67 | my ( $self, $class ) = @_; | ||||
62 | my $test_info = _test_info($self) | ||||||
63 | or die "Test::Class internals seem confused. Did you override " | ||||||
64 | 38 38 | 61 238 | . "new() in a sub-class or via multiple inheritence?\n"; | ||||
65 | return values %{ $test_info->{$class} }; | ||||||
66 | }; | ||||||
67 | |||||||
68 | 74 | 188 | sub _parse_attribute_args { | ||||
69 | 74 | 74 | my $args = shift || ''; | ||||
70 | 74 | 113 | my $num_tests; | ||||
71 | 74 | 123 | my $type; | ||||
72 | 74 | 194 | $args =~ s/\s+//sg; | ||||
73 | 65 | 185 | foreach my $arg (split /=>/, $args) { | ||||
74 | 65 | 158 | if (Test::Class::MethodInfo->is_num_tests($arg)) { | ||||
75 | $num_tests = $arg; | ||||||
76 | 0 | 0 | } elsif (Test::Class::MethodInfo->is_method_type($arg)) { | ||||
77 | $type = $arg; | ||||||
78 | 0 | 0 | } else { | ||||
79 | die 'bad attribute args'; | ||||||
80 | }; | ||||||
81 | 74 | 206 | }; | ||||
82 | return( $type, $num_tests ); | ||||||
83 | }; | ||||||
84 | |||||||
85 | 74 | 117 | sub _is_public_method { | ||||
86 | 74 | 159 | my ($class, $name) = @_; | ||||
87 | 74 | 1007 | foreach my $parent_class ( Class::ISA::super_path( $class ) ) { | ||||
88 | 0 | 0 | return unless $parent_class->can( $name ); | ||||
89 | return if _method_info( $class, $parent_class, $name ); | ||||||
90 | 0 | 0 | } | ||||
91 | return 1; | ||||||
92 | } | ||||||
93 | |||||||
94 | 74 | 157 | sub Test : ATTR(CODE,RAWDATA) { | ||||
95 | 74 | 242 | my ($class, $symbol, $code_ref, $attr, $args) = @_; | ||||
96 | 0 | 0 | if ($symbol eq "ANON") { | ||||
97 | warn "cannot test anonymous subs - you probably loaded a Test::Class too late (after the CHECK block was run). See 'A NOTE ON LOADING TEST CLASSES' in perldoc Test::Class for more details\n"; | ||||||
98 | 74 74 | 74 173 | } else { | ||||
99 | 74 | 153 | my $name = *{$symbol}{NAME}; | ||||
100 | warn "overriding public method $name with a test method in $class\n" | ||||||
101 | 74 | 123 | if _is_public_method( $class, $name ); | ||||
102 | 74 | 139 | eval { | ||||
103 | 74 | 247 | my ($type, $num_tests) = _parse_attribute_args($args); | ||||
104 | $Tests->{$class}->{$name} = Test::Class::MethodInfo->new( | ||||||
105 | name => $name, | ||||||
106 | num_tests => $num_tests, | ||||||
107 | type => $type, | ||||||
108 | ); | ||||||
109 | } || warn "bad test definition '$args' in $class->$name\n"; | ||||||
110 | 2 2 | 78 5 | }; | ||||
111 | }; | ||||||
112 | |||||||
113 | 9 | 20 | sub Tests : ATTR(CODE,RAWDATA) { | ||||
114 | 9 | 20 | my ($class, $symbol, $code_ref, $attr, $args) = @_; | ||||
115 | 9 | 13 | $args ||= 'no_plan'; | ||||
116 | 2 2 | 12 4 | Test( $class, $symbol, $code_ref, $attr, $args ); | ||||
117 | }; | ||||||
118 | |||||||
119 | 184 | 268 | sub _class_of { | ||||
120 | 184 | 669 | my $self = shift; | ||||
121 | return ref $self ? ref $self : $self; | ||||||
122 | } | ||||||
123 | |||||||
124 | 2 | 5 | sub new { | ||||
125 | 2 | 8 | my $proto = shift; | ||||
126 | 2 | 10 | my $class = _class_of( $proto ); | ||||
127 | 2 | 25 | $proto = {} unless ref($proto); | ||||
128 | 2 | 1116 | my $self = bless {%$proto, @_}, $class; | ||||
129 | 2 | 9 | $_Test{$self} = dclone($Tests); | ||||
130 | return($self); | ||||||
131 | }; | ||||||
132 | |||||||
133 | 22 | 53 | sub _get_methods { | ||||
134 | 22 | 38 | my ( $self, @types ) = @_; | ||||
135 | my $test_class = _class_of( $self ); | ||||||
136 | |||||||
137 | 22 22 | 31 155 | my $test_method_regexp = $ENV{ TEST_METHOD } || '.*'; | ||||
138 | 22 | 47 | my $method_regexp = eval { qr/\A$test_method_regexp\z/ }; | ||||
139 | die "TEST_METHOD ($test_method_regexp) is not a valid regexp: $@" if $@; | ||||||
140 | |||||||
141 | 22 | 65 | my %methods = (); | ||||
142 | 38 | 1200 | foreach my $class ( Class::ISA::self_and_super_path( $test_class ) ) { | ||||
143 | 592 | 5163 | foreach my $info ( _methods_of_class( $self, $class ) ) { | ||||
144 | 592 | 3282 | my $name = $info->name; | ||||
145 | 740 | 2972 | foreach my $type ( @types ) { | ||||
146 | 148 | 2290 | if ( $info->is_type( $type ) ) { | ||||
147 | $methods{ $name } = 1 | ||||||
148 | unless $type eq TEST && $name !~ $method_regexp; | ||||||
149 | } | ||||||
150 | }; | ||||||
151 | }; | ||||||
152 | }; | ||||||
153 | |||||||
154 | return sort keys %methods; | ||||||
155 | }; | ||||||
156 | |||||||
157 | 4 | 9 | sub _num_expected_tests { | ||||
158 | 4 | 8 | my $self = shift; | ||||
159 | 0 | 0 | if (my $reason = $self->SKIP_CLASS ) { | ||||
160 | return $reason eq "1" ? 0 : 1; | ||||||
161 | 4 | 9 | }; | ||||
162 | my @startup_shutdown_methods = | ||||||
163 | 4 | 10 | _get_methods($self, STARTUP, SHUTDOWN); | ||||
164 | my $num_startup_shutdown_methods = | ||||||
165 | 4 | 13 | _total_num_tests($self, @startup_shutdown_methods); | ||||
166 | 4 | 10 | return(NO_PLAN) if $num_startup_shutdown_methods eq NO_PLAN; | ||||
167 | 4 | 10 | my @fixture_methods = _get_methods($self, SETUP, TEARDOWN); | ||||
168 | 4 | 14 | my $num_fixture_tests = _total_num_tests($self, @fixture_methods); | ||||
169 | 4 | 8 | return(NO_PLAN) if $num_fixture_tests eq NO_PLAN; | ||||
170 | 4 | 40 | my @test_methods = _get_methods($self, TEST); | ||||
171 | 4 | 21 | my $num_tests = _total_num_tests($self, @test_methods); | ||||
172 | 3 | 21 | return(NO_PLAN) if $num_tests eq NO_PLAN; | ||||
173 | return($num_startup_shutdown_methods + $num_tests + @test_methods * $num_fixture_tests); | ||||||
174 | }; | ||||||
175 | |||||||
176 | 2 | 3 | sub expected_tests { | ||||
177 | 2 | 5 | my $total = 0; | ||||
178 | 4 | 10 | foreach my $test (@_) { | ||||
179 | 4 | 12 | if ( _isa_class( __PACKAGE__, $test ) ) { | ||||
180 | 4 | 12 | my $n = _num_expected_tests($test); | ||||
181 | 3 | 8 | return NO_PLAN if $n eq NO_PLAN; | ||||
182 | $total += $n; | ||||||
183 | 0 | 0 | } elsif ( defined $test && $test =~ m/^\d+$/ ) { | ||||
184 | $total += $test; | ||||||
185 | 0 | 0 | } else { | ||||
186 | 0 | 0 | $test = 'undef' unless defined $test; | ||||
187 | croak "$test is not a Test::Class or an integer"; | ||||||
188 | }; | ||||||
189 | 1 | 3 | }; | ||||
190 | return $total; | ||||||
191 | }; | ||||||
192 | |||||||
193 | 160 | 343 | sub _total_num_tests { | ||||
194 | 160 | 309 | my ($self, @methods) = @_; | ||||
195 | 160 | 203 | my $class = _class_of( $self ); | ||||
196 | 160 | 298 | my $total_num_tests = 0; | ||||
197 | 199 | 539 | foreach my $method (@methods) { | ||||
198 | 199 | 10864 | foreach my $class (Class::ISA::self_and_super_path($class)) { | ||||
199 | 199 | 519 | my $info = _method_info($self, $class, $method); | ||||
200 | 199 | 672 | next unless $info; | ||||
201 | 199 | 2285 | my $num_tests = $info->num_tests; | ||||
202 | 194 | 291 | return(NO_PLAN) if ($num_tests eq NO_PLAN); | ||||
203 | 194 | 851 | $total_num_tests += $num_tests; | ||||
204 | last unless $num_tests =~ m/^\+/ | ||||||
205 | }; | ||||||
206 | 155 | 664 | }; | ||||
207 | return($total_num_tests); | ||||||
208 | }; | ||||||
209 | |||||||
210 | 74 | 119 | sub _has_no_tests { | ||||
211 | 74 | 133 | my ( $self, $method ) = @_; | ||||
212 | return _total_num_tests( $self, $method ) eq '0'; | ||||||
213 | } | ||||||
214 | |||||||
215 | 74 | 151 | sub _all_ok_from { | ||||
216 | 74 | 236 | my ($self, $start_test) = @_; | ||||
217 | 74 | 163 | my $current_test = $Builder->current_test; | ||||
218 | 74 | 375 | return(1) if $start_test == $current_test; | ||||
219 | 74 274 | 375 545 | my @results = ($Builder->summary)[$start_test .. $current_test-1]; | ||||
220 | 74 | 779 | foreach my $result (@results) { return(0) unless $result }; | ||||
221 | return(1); | ||||||
222 | }; | ||||||
223 | |||||||
224 | 0 | 0 | sub _exception_failure { | ||||
225 | 0 | 0 | my ($self, $method, $exception, $tests) = @_; | ||||
226 | 0 | 0 | local $Test::Builder::Level = 3; | ||||
227 | 0 | 0 | my $message = $method; | ||||
228 | $message .= " (for test method '$Current_method')" | ||||||
229 | 0 | 0 | if defined $Current_method && $method ne $Current_method; | ||||
230 | 0 | 0 | _show_header($self, @$tests); | ||||
231 | $Builder->ok(0, "$message died ($exception)"); | ||||||
232 | }; | ||||||
233 | |||||||
234 | 74 | 151 | sub _run_method { | ||||
235 | 74 | 199 | my ($self, $method, $tests) = @_; | ||||
236 | 74 | 96 | my $num_start = $Builder->current_test; | ||||
237 | 74 | 138 | my $skip_reason; | ||||
238 | 2 2 2 | 16 14 12 | my $original_ok = \&Test::Builder::ok; | ||||
239 | no warnings; | ||||||
240 | 254 | 543 | local *Test::Builder::ok = sub { | ||||
241 | 254 | 372 | my ($builder, $test, $description) = @_; | ||||
242 | 254 | 535 | local $Test::Builder::Level = $Test::Builder::Level+1; | ||||
243 | 254 | 703 | unless ( defined($description) ) { | ||||
244 | 254 | 504 | $description = $self->current_method; | ||||
245 | $description =~ tr/_/ /; | ||||||
246 | 254 | 765 | }; | ||||
247 | 254 | 456 | my $is_ok = $original_ok->($builder, $test, $description); | ||||
248 | 0 | 0 | unless ( $is_ok ) { | ||||
249 | 0 | 0 | my $class = ref $self; | ||||
250 | $Builder->diag( " (in $class->$method)" ); | ||||||
251 | 254 | 802 | }; | ||||
252 | 74 | 735 | return $is_ok; | ||||
253 | 74 74 | 108 323 | }; | ||||
254 | 74 | 1752 | $skip_reason = eval {$self->$method}; | ||||
255 | 74 | 136 | $skip_reason = $method unless $skip_reason; | ||||
256 | 74 | 149 | my $exception = $@; | ||||
257 | 74 | 258 | chomp($exception) if $exception; | ||||
258 | 74 | 205 | my $num_done = $Builder->current_test - $num_start; | ||||
259 | 74 | 190 | my $num_expected = _total_num_tests($self, $method); | ||||
260 | 74 | 179 | $num_expected = $num_done if $num_expected eq NO_PLAN; | ||||
261 | 60 | 147 | if ($num_done == $num_expected) { | ||||
262 | _exception_failure($self, $method, $exception, $tests) | ||||||
263 | unless $exception eq ''; | ||||||
264 | 0 | 0 | } elsif ($num_done > $num_expected) { | ||||
265 | $Builder->diag("expected $num_expected test(s) in $method, $num_done completed\n"); | ||||||
266 | 14 | 51 | } else { | ||||
267 | 20 | 46 | until (($Builder->current_test - $num_start) >= $num_expected) { | ||||
268 | 0 | 0 | if ($exception ne '') { | ||||
269 | 0 | 0 | _exception_failure($self, $method, $exception, $tests); | ||||
270 | 0 | 0 | $skip_reason = "$method died"; | ||||
271 | $exception = ''; | ||||||
272 | 20 | 65 | } else { | ||||
273 | $Builder->skip( $skip_reason ); | ||||||
274 | }; | ||||||
275 | }; | ||||||
276 | 74 | 186 | }; | ||||
277 | return(_all_ok_from($self, $num_start)); | ||||||
278 | }; | ||||||
279 | |||||||
280 | 74 | 158 | sub _show_header { | ||||
281 | 74 | 258 | my ($self, @tests) = @_; | ||||
282 | 2 | 9 | return if $Builder->has_plan; | ||||
283 | 2 | 7 | my $num_tests = Test::Class->expected_tests(@tests); | ||||
284 | 1 | 6 | if ($num_tests eq NO_PLAN) { | ||||
285 | $Builder->no_plan; | ||||||
286 | 1 | 6 | } else { | ||||
287 | $Builder->expected_tests($num_tests); | ||||||
288 | }; | ||||||
289 | }; | ||||||
290 | |||||||
291 | my %SKIP_THIS_CLASS = (); | ||||||
292 | |||||||
293 | 6 | 12 | sub SKIP_CLASS { | ||||
294 | 6 | 14 | my $class = shift; | ||||
295 | 6 | 30 | $SKIP_THIS_CLASS{ $class } = shift if @_; | ||||
296 | return $SKIP_THIS_CLASS{ $class }; | ||||||
297 | }; | ||||||
298 | |||||||
299 | 401 | 617 | sub _isa_class { | ||||
300 | 401 | 665 | my ( $class, $object_or_class ) = @_; | ||||
301 | 401 | 671 | return unless defined $object_or_class; | ||||
302 | 401 | 428 | return if $object_or_class eq 'Contextual::Return::Value'; | ||||
303 | 401 | 4575 | return eval { | ||||
304 | $object_or_class->isa( $class ) and $object_or_class->can( 'runtests' ) | ||||||
305 | }; | ||||||
306 | } | ||||||
307 | |||||||
308 | 2 | 4 | sub _test_classes { | ||||
309 | 2 395 | 21 609 | my $class = shift; | ||||
310 | return grep { _isa_class( $class, $_ ) } Devel::Symdump->rnew->packages; | ||||||
311 | }; | ||||||
312 | |||||||
313 | 2 | 34 | sub runtests { | ||||
314 | die "Test::Class was loaded too late (after the CHECK block was run). See 'A NOTE ON LOADING TEST CLASSES' in perldoc Test::Class for more details\n" | ||||||
315 | 2 | 6 | unless $Check_block_has_run; | ||||
316 | 2 | 17 | my @tests = @_; | ||||
317 | 2 | 5 | if (@tests == 1 && !ref($tests[0])) { | ||||
318 | 2 | 8 | my $base_class = shift @tests; | ||||
319 | @tests = _test_classes( $base_class ); | ||||||
320 | 2 | 6 | }; | ||||
321 | 2 | 2583 | my $all_passed = 1; | ||||
322 | TEST_OBJECT: foreach my $t (@tests) { | ||||||
323 | 2 | 20 | # SHOULD ALSO ALLOW NO_PLAN | ||||
324 | 2 | 7 | next if $t =~ m/^\d+$/; | ||||
325 | croak "$t is not Test::Class or integer" | ||||||
326 | 2 | 13 | unless _isa_class( __PACKAGE__, $t ); | ||||
327 | 0 | 0 | if (my $reason = $t->SKIP_CLASS) { | ||||
328 | 0 | 0 | _show_header($t, @tests); | ||||
329 | $Builder->skip( $reason ) unless $reason eq "1"; | ||||||
330 | 2 | 16 | } else { | ||||
331 | 2 | 7 | $t = $t->new unless ref($t); | ||||
332 | 0 | 0 | foreach my $method (_get_methods($t, STARTUP)) { | ||||
333 | 0 | 0 | _show_header($t, @tests) unless _has_no_tests($t, $method); | ||||
334 | 0 | 0 | my $method_passed = _run_method($t, $method, \@tests); | ||||
335 | 0 | 0 | $all_passed = 0 unless $method_passed; | ||||
336 | next TEST_OBJECT unless $method_passed; | ||||||
337 | 2 | 6 | }; | ||||
338 | 2 | 6 | my $class = ref($t); | ||||
339 | 2 | 6 | my @setup = _get_methods($t, SETUP); | ||||
340 | 2 | 8 | my @teardown = _get_methods($t, TEARDOWN); | ||||
341 | 74 | 136 | foreach my $test (_get_methods($t, TEST)) { | ||||
342 | 74 | 206 | local $Current_method = $test; | ||||
343 | 74 | 133 | $Builder->diag("\n$class->$test") if $ENV{TEST_VERBOSE}; | ||||
344 | 74 | 154 | foreach my $method (@setup, $test, @teardown) { | ||||
345 | 74 | 238 | _show_header($t, @tests) unless _has_no_tests($t, $method); | ||||
346 | $all_passed = 0 unless _run_method($t, $method, \@tests); | ||||||
347 | }; | ||||||
348 | 2 | 64 | }; | ||||
349 | 0 | 0 | foreach my $method (_get_methods($t, SHUTDOWN)) { | ||||
350 | 0 | 0 | _show_header($t, @tests) unless _has_no_tests($t, $method); | ||||
351 | $all_passed = 0 unless _run_method($t, $method, \@tests); | ||||||
352 | } | ||||||
353 | } | ||||||
354 | 2 | 2 | } | ||||
355 | return($all_passed); | ||||||
356 | }; | ||||||
357 | |||||||
358 | 0 | sub _find_calling_test_class { | |||||
359 | 0 | my $level = 0; | |||||
360 | 0 | while (my $class = caller(++$level)) { | |||||
361 | 0 | next if $class eq __PACKAGE__; | |||||
362 | return $class if _isa_class( __PACKAGE__, $class ); | ||||||
363 | 0 | }; | |||||
364 | return(undef); | ||||||
365 | }; | ||||||
366 | |||||||
367 | 0 | sub num_method_tests { | |||||
368 | 0 | my ($self, $method, $n) = @_; | |||||
369 | my $class = _find_calling_test_class( $self ) | ||||||
370 | 0 | or croak "not called in a Test::Class"; | |||||
371 | my $info = _method_info($self, $class, $method) | ||||||
372 | 0 | or croak "$method is not a test method of class $class"; | |||||
373 | 0 | $info->num_tests($n) if defined($n); | |||||
374 | return( $info->num_tests ); | ||||||
375 | }; | ||||||
376 | |||||||
377 | 0 | sub num_tests { | |||||
378 | 0 | my $self = shift; | |||||
379 | croak "num_tests need to be called within a test method" | ||||||
380 | 0 | unless defined $Current_method; | |||||
381 | return( $self->num_method_tests( $Current_method, @_ ) ); | ||||||
382 | }; | ||||||
383 | |||||||
384 | 0 | sub BAILOUT { | |||||
385 | 0 | my ($self, $reason) = @_; | |||||
386 | $Builder->BAILOUT($reason); | ||||||
387 | }; | ||||||
388 | |||||||
389 | 0 | sub _last_test_if_exiting_immediately { | |||||
390 | $Builder->expected_tests || $Builder->current_test+1 | ||||||
391 | }; | ||||||
392 | |||||||
393 | 0 | sub FAIL_ALL { | |||||
394 | 0 | my ($self, $reason) = @_; | |||||
395 | 0 | my $last_test = _last_test_if_exiting_immediately(); | |||||
396 | 0 | $Builder->expected_tests( $last_test ) unless $Builder->has_plan; | |||||
397 | 0 | $Builder->ok(0, $reason) until $Builder->current_test >= $last_test; | |||||
398 | 0 | my $num_failed = grep( !$_, $Builder->summary ); | |||||
399 | exit( $num_failed < 254 ? $num_failed : 254 ); | ||||||
400 | }; | ||||||
401 | |||||||
402 | 0 | sub SKIP_ALL { | |||||
403 | 0 | my ($self, $reason) = @_; | |||||
404 | 0 | $Builder->skip_all( $reason ) unless $Builder->has_plan; | |||||
405 | 0 | my $last_test = _last_test_if_exiting_immediately(); | |||||
406 | $Builder->skip( $reason ) | ||||||
407 | 0 | until $Builder->current_test >= $last_test; | |||||
408 | exit(0); | ||||||
409 | } | ||||||
410 | |||||||
411 | 1; | ||||||
412 |