| 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 | |||||||