File Coverage

File:inc/Test/Class.pm
Coverage:68.3%

linestmtbrancondsubpodtimecode
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;
4use 5.006;
5
6package 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;
14use Test::Class::MethodInfo;
15
16our $VERSION = '0.30';
17
18my $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";
29use constant SHUTDOWN => "shutdown";
30
31
32
254
591
our $Current_method = undef;
33sub current_method { $Current_method };
34
35
36
0
0
my $Builder = Test::Builder->new;
37sub builder { $Builder };
38
39
40my $Tests = {};
41
42
43my %_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
291my %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
4111;
412