view release on metacpan or  search on metacpan

inc/Test/Class.pm  view on Meta::CPAN

    my ( $class, $object_or_class ) = @_;
    return unless defined $object_or_class;
    return if $object_or_class eq 'Contextual::Return::Value';
    return eval { 
        $object_or_class->isa( $class ) and $object_or_class->can( 'runtests' )
    };
}

sub _test_classes {
	my $class = shift;
	return grep { _isa_class( $class, $_ ) } Devel::Symdump->rnew->packages;
};

sub runtests {
    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"
        unless $Check_block_has_run;
	my @tests = @_;
	if (@tests == 1 && !ref($tests[0])) {
		my $base_class = shift @tests;
		@tests = _test_classes( $base_class );
	};
	my $all_passed = 1;
	TEST_OBJECT: 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);
            $Builder->skip( $reason ) unless $reason eq "1";
        } else {
            $t = $t->new unless ref($t);
            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 (_get_methods($t, TEST)) { 
                local $Current_method = $test;
                $Builder->diag("\n$class->$test") if $ENV{TEST_VERBOSE};
                foreach my $method (@setup, $test, @teardown) {
                    _show_header($t, @tests) unless _has_no_tests($t, $method);
                    $all_passed = 0 unless _run_method($t, $method, \@tests);
                };
            };
            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);
            }
        }
	}
	return($all_passed);
};

sub _find_calling_test_class {
	my $level = 0;
	while (my $class = caller(++$level)) {
		next if $class eq __PACKAGE__;
		return $class if _isa_class( __PACKAGE__, $class );
	}; 
	return(undef);
};

sub num_method_tests {
	my ($self, $method, $n) = @_;
	my $class = _find_calling_test_class( $self )
	    or croak "not called in a Test::Class";
	my $info = _method_info($self, $class, $method)
	    or croak "$method is not a test method of class $class";
	$info->num_tests($n) if defined($n);
	return( $info->num_tests );
};

sub num_tests {
    my $self = shift;
	croak "num_tests need to be called within a test method"
			unless defined $Current_method;
	return( $self->num_method_tests( $Current_method, @_ ) );
};

sub BAILOUT {
	my ($self, $reason) = @_;
	$Builder->BAILOUT($reason);
};

sub _last_test_if_exiting_immediately {
    $Builder->expected_tests || $Builder->current_test+1
};

sub FAIL_ALL {
	my ($self, $reason) = @_;
	my $last_test = _last_test_if_exiting_immediately();
	$Builder->expected_tests( $last_test ) unless $Builder->has_plan;
	$Builder->ok(0, $reason) until $Builder->current_test >= $last_test;
	my $num_failed = grep( !$_, $Builder->summary );
	exit( $num_failed < 254 ? $num_failed : 254 );
};

sub SKIP_ALL {	
	my ($self, $reason) = @_;
	$Builder->skip_all( $reason ) unless $Builder->has_plan;
	my $last_test = _last_test_if_exiting_immediately();
	$Builder->skip( $reason ) 
	    until $Builder->current_test >= $last_test;
	exit(0);
}

1;

__END__