File Coverage

blib/lib/Test/Able/Role/Meta/Class.pm

Criterion	Covered	Total	%
statement	183	187	97.8
branch	61	70	87.1
condition	15	18	83.3
subroutine	26	26	100.0
pod	6	6	100.0
total	291	307	94.7

package Test::Able::Role::Meta::Class;

use Moose::Role;
use Moose::Util::TypeConstraints;
use Scalar::Util;
use strict;
use Test::Able::Role::Meta::Method;
use Test::Able::Method::Array;
use warnings;

with qw( Test::Able::Planner );

=head1 NAME

Test::Able::Role::Meta::Class - Main metarole

=head1 DESCRIPTION

This metarole gets applied to the Moose::Meta::Class metaclass objects
for all Test::Able objects.  This metarole also pulls in
L<Test::Able::Planner>.

=head1 ATTRIBUTES

=over

=item method_types

The names of the different types of test-related methods.
The default set is startup, setup, test, teardown, and shutdown.

=cut

has 'method_types' => (
    is => 'ro', isa => 'ArrayRef', lazy_build => 1,
);

=item *_methods

The test-related method lists.  There will be one for each method
type.  The default set will be:

startup_methods
setup_methods
test_methods
teardown_methods
shutdown_methods

These lists are what forms the basis of the test execution plan.

The lists themselves will be coerced into L<Test::Able::Method::Array> objects
just for the convenience of overloading for hash access.  The elements of the
lists will be L<Test::Able::Role::Meta::Method>-based method metaclass
objects.

=cut

for ( @{ __PACKAGE__->_build_method_types } ) {
    has "${_}_methods" => (
        is => 'rw', isa => 'Test::Able::MethodArray', lazy_build => 1,
        coerce => 1,
        trigger => sub {
            my ( $self, $value, ) = @_;

            $self->clear_plan;

            return;
        },
    );
}

subtype 'Test::Able::MethodArray'
  => as 'Object'
  => where { $_->isa( 'Test::Able::Method::Array' ); };

coerce 'Test::Able::MethodArray'
  => from 'ArrayRef'
  => via { bless( $_, 'Test::Able::Method::Array' ); };

=item test_objects

The list of L<Test::Able::Object>-based objects that the test runner
object will iterate through to make up the test run.

=cut

has 'test_objects' => (
    is => 'rw', isa => 'ArrayRef', lazy_build => 1,
);

=item current_test_object

The test object that is currently being executed (or introspected).

=cut

has 'current_test_object' => (
    is => 'rw', isa => 'Object', clearer => 'clear_current_test_object',
);

=item current_test_method

The method metaclass object of the associated test method.
This is only useful from within a setup or teardown method.
Its also available in the test method itself but current_method()
would be exactly the same in a test method and its shorter to type.

=cut

has 'current_test_method' => (
    is => 'rw', isa => 'Object', clearer => 'clear_current_test_method',
);

=item current_method

The method metaclass object of the currently executing test-related
method.

=cut

has 'current_method' => (
    is => 'rw', isa => 'Object', clearer => 'clear_current_method',
);

=item test_runner_object

The test object that will be running the show.  It may itself be in the
test_objects list.  The run_tests() method sets this value to its invocant.

=cut

has 'test_runner_object' => (
    is => 'rw', isa => 'Object',
);

=item dry_run

Setting this true will cause all test-related method execution to be skipped.
This means things like method exception handling, method plan handling, and
Test::Builder integration will also not happen.  One use of this could be to
print out the execution plan.  The default is 0.

=cut

has 'dry_run' => (
    is => 'rw', isa => 'Bool', default => 0,
);

=item on_method_plan_fail

Determines what is done, if anything, when the observed method plan doesn't
match the expected method plan after the test-related method runs.  If this
attribute is not set then nothing special is done.  Setting this to log or die
will cause the failure to be logged via log() or just died upon.  The default
is log.

=cut

enum 'Test::Able::MethodPlanFailAction' => qw( die log );

has 'on_method_plan_fail' => (
    is => 'rw', isa => 'Test::Able::MethodPlanFailAction', default => 'log',
    clearer => 'clear_on_method_plan_fail',
);

=item on_method_exception

Determines what is done, if anything, when an exception is thrown within a
test-related method.

If this attribute isn't set then the exception is simply rethrown.  This is
the default.

If its set to "continue" then the exception will be silently ignored.

And if set to "continue_at_level" the exception will also be silently ignored
and the test runner will skip over lower levels, if there are any, of the test
execution plan.  The levels are defined as follows. The startup and shutdown
methods are at the first level.  The setup and teardown methods are the second
level.  And test methods are the third and last level.  Or in visual form:

 startup
     setup
         test
     teardown
 shutdown

In addition, when this attribute is set to continue or continue_at_level the
exceptions will be recorded in the method_exceptions attribute of the
currently executing test object.

There is only one way to cause a fatal exception when this attribute is set to
continue or continue_at_level.  And that is to throw a
L<Test::Able::FatalException> exception.

=cut

enum 'Test::Able::MethodExceptionAction' => qw( continue continue_at_level );

has 'on_method_exception' => (
    is => 'rw', isa => 'Test::Able::MethodExceptionAction',
    clearer => 'clear_on_method_exception',
);

=item method_exceptions

List of exceptions that have occurred while inside a test-related method in
this test object.  Each element of the list is a hashref that looks like this:

 {
     method    => $self->current_method,
     exception => $exception,
 }

=back

=cut

has 'method_exceptions' => (
    is => 'rw', isa => 'ArrayRef[HashRef]', lazy_build => 1,
);

sub _build_method_types {
    my ( $self, ) = @_;

    return [ qw( startup setup test teardown shutdown ) ];
}

sub _build_startup_methods {
    my ( $self, ) = @_;

    return $self->build_methods( 'startup' );
}

sub _build_setup_methods {
    my ( $self, ) = @_;

    return $self->build_methods( 'setup' );
}

sub _build_test_methods {
    my ( $self, ) = @_;

    return $self->build_methods( 'test' );
}

sub _build_teardown_methods {
    my ( $self, ) = @_;

    return $self->build_methods( 'teardown' );
}

sub _build_shutdown_methods {
    my ( $self, ) = @_;

    return $self->build_methods( 'shutdown' );
}

sub _build_test_objects {
    my ( $self, ) = @_;

    return $self->current_test_object
      ? [ $self->current_test_object, ] : [];
}

sub _build_method_exceptions { []; }

=head1 METHODS

=over

=item run_tests

The main test runner method.  Iterates over test_objects list calling
run_methods() to run through the test execution plan.

Manages test_runner_object, current_test_object, runner_plan, and
last_runner_plan along the way.

=cut
sub run_tests {
    my ( $self, ) = @_;

    $self->test_runner_object( $self, );
    for my $test_object ( @{ $self->test_objects } ) {
        $test_object->meta->test_runner_object( $self, );
    }

    # Initial plan calc.
    $self->runner_plan;

    $self->log( "$self->run_tests() called but there are no test objects" )
      unless @{ $self->test_objects };
    for my $test_object ( @{ $self->test_objects } ) {
        $test_object->meta->current_test_object( $test_object );

        my $exceptions_before_startup = @{ $self->method_exceptions };
        $test_object->meta->run_methods( 'startup'  );
        $test_object->meta->run_methods( 'test'     )
          if $exceptions_before_startup == @{ $self->method_exceptions };
        $test_object->meta->run_methods( 'shutdown' );

        $test_object->meta->clear_current_test_object;
    }

    # Finalize planning for this run.
    $self->clear_runner_plan;
    $self->runner_plan;
    $self->clear_last_runner_plan;

    return;
}

=item run_methods

Executes a test-related method list as part of the test execution plan.  Takes
one argument and that's the name of the test-related method type.  Also, for
each test method, it calls run_methods() for the setup and teardown method
lists.

=cut

sub run_methods {
    my ( $self, $type, ) = @_;

    my $accessor_name = $type . '_methods';
    my $methods       = $self->$accessor_name;
    my $count         = @{ $methods };
    my $i;
    for my $method ( @{ $methods } ) {
        my $setup_exception_count;
        if ( $type eq 'test' ) {
            $self->current_test_method( $method );
            my $exceptions_before_setup = @{ $self->method_exceptions };
            $self->run_methods( 'setup' ) if $method->do_setup;
            $setup_exception_count
              = @{ $self->method_exceptions } - $exceptions_before_setup;
        }

        my $method_name = $method->name;
        unless ( $setup_exception_count ) {
            $self->current_method( $method );
            $self->log(
                $self->current_test_object . '->' . $method_name
                . "($type/" . $method->plan . ")"
                . '('. ++$i . "/$count)"
            );
        }

        unless ( $setup_exception_count || $self->dry_run ) {
            my $tests_before = $self->builder->{Curr_Test};

            eval { $self->current_test_object->$method_name; };
            if ( my $exception = $@ ) {
                die $exception unless $self->on_method_exception;

                my $test_object_meta = $self->current_test_object->meta;
                push(
                    @{ $test_object_meta->method_exceptions },
                    {
                        method    => $self->current_method,
                        exception => $exception,
                    }
                );

                die $exception if Scalar::Util::blessed( $exception )
                  && $exception->isa( 'Test::Able::FatalException' );
            }

            if ( $self->on_method_plan_fail && $method->plan =~ /^\d+$/ ) {
                my $tests_diff = $self->builder->{Curr_Test} - $tests_before;
                if ( $tests_diff != $method->plan ) {
                    my $msg = "Method $method_name planned " . $method->plan
                      . " tests but ran $tests_diff.";
                    if ( $self->on_method_plan_fail eq 'die' ) {
                        die "$msg\n";
                    }
                    else { $self->log( $msg ); }
                }
            }
        }

        if ( $type eq 'test' ) {
            $self->run_methods( 'teardown' ) if $method->do_teardown;
            $self->clear_current_test_method;
        }
        $self->clear_current_method;
    }

    return;
}

=item build_methods

Builds a test-related method list from the method metaclass objects associated
with this metaclass object.  The method list is sorted alphabetically by
method name.  Takes one argument and that's the name of the test-related
method type.

=cut

sub build_methods {
    my ( $self, $type, ) = @_;

    my @methods;
    for my $method ( $self->current_test_object->meta->get_all_methods ) {
        if ( $method->can( 'type' ) ) {
            my $method_type = $method->type;
            push( @methods, $method )
              if defined $method_type && $method_type eq $type;
        }
    }

    return bless(
        [ sort {
            $a->order <=> $b->order || $a->name cmp $b->name
        } @methods ],
        'Test::Able::Method::Array'
    );
}

=item build_all_methods

Convenience method to call build_methods() for all method types.

=cut

sub build_all_methods {
    my ( $self, ) = @_;

    for my $type ( @{ $self->method_types } ) {
        my $accessor_name =          $type . '_methods';
        my $has_name      = 'has_' . $type . '_methods';
        $self->$accessor_name unless $self->$has_name;
    }

    return;
}

=item clear_all_methods

Convenience method to clear all the test-related method lists out.

=cut

sub clear_all_methods {
    my ( $self, ) = @_;

    for my $type ( @{ $self->method_types } ) {
        my $clear_name = 'clear_' . $type . '_methods';
        my $has_name   = 'has_'   . $type . '_methods';
        $self->$clear_name if $self->$has_name;
    }

    return;
}

=item log

All logging goes through this method.  It sends its args along to
Test::Builder::diag.  And only if $ENV{TEST_VERBOSE} is set.

=cut

sub log {
    my $self = shift;

    $self->builder->diag( @_ ) if $ENV{ 'TEST_VERBOSE' };

    return;
}

sub _build_plan {
    my ( $self, ) = @_;

    my $plan;
    my $test_method_with_setup_count = grep {
        $_->do_setup;
    } @{ $self->test_methods };
    my $test_method_with_teardown_count = grep {
        $_->do_teardown;
    } @{ $self->test_methods };
    METHOD_TYPE: for my $type ( @{ $self->method_types } ) {
        my $accessor_name = $type . '_methods';
        for my $method ( @{ $self->$accessor_name } ) {
                if ( $method->plan eq 'no_plan' ) {
                    $plan = $method->plan;
                    last METHOD_TYPE;
                }
                else {
                    if ( $accessor_name eq 'setup_methods' ) {
                        $plan
                          += $method->plan * $test_method_with_setup_count;
                    }
                    elsif ( $accessor_name eq 'teardown_methods' ) {
                        $plan
                          += $method->plan * $test_method_with_teardown_count;
                    }
                    else { $plan += $method->plan; }
                }
        }
    }
    $plan = 'no_plan' unless defined $plan;

    return $plan;
}

=item clear_plan

Special purpose plan clearer that dumps the test object's plan and the test
runner's plan in one shot.

=back

=cut

#TODO: Could change this if Class::MOP bug 41449 is resolved.
#sub clear_plan {
before 'clear_plan' => sub {
    my ( $self, ) = @_;

    delete $self->{ 'plan' };
    delete $self->{ 'runner_plan' };

    return;
};
#}

# Hack Test::Builder because it doesn't do plan alterations.
sub _build_runner_plan {
    my ( $self, ) = @_;

    $self->_hack_test_builder( $self->builder );

    # Compute current plan.
    my $plan;
    for my $test_object ( @{ $self->test_objects } ) {
        $test_object->meta->current_test_object( $test_object );

        my $object_plan = $test_object->meta->plan;
        if ( $object_plan eq 'no_plan' ) {
            $plan = $object_plan;
            last;
        }
        else { $plan += $object_plan; }

        $test_object->meta->clear_current_test_object;
    }
    $plan = 'no_plan' unless defined $plan;

    return $plan if $self->dry_run;

    $self->builder->no_plan unless $self->builder->has_plan;

    # Update Test::Builder.
    if ( $self->builder->{No_Plan} || $self->builder->{was_No_Plan} ) {
        if ( $plan =~ /^\d+$/ ) {
            if ( $self->has_last_runner_plan ) {
                my $last = $self->last_runner_plan;
                my $plan_diff = $plan - ( $last eq 'no_plan' ? 0 : $last );
                $self->builder->{Expected_Tests} += $plan_diff;
            }
            else {
                $self->builder->{Expected_Tests} += $plan;
            }
                $self->builder->{No_Plan}     = 0;
                $self->builder->{was_No_Plan} = 1;
                $self->last_runner_plan( $plan );
        }
        else { $self->builder->{No_Plan} = 1; }
    }

    return $plan;
}

#TODO:  dump this ASAP.
# Hack Test::Builder cause it doesn't do deferred plans; yet.
my $hacked_test_builder;
sub _hack_test_builder {
    my ( $self, ) = @_;

    return if $hacked_test_builder;
    $hacked_test_builder++;
    no warnings 'redefine';
    my $original_sub = \&Test::Builder::_ending;
    *Test::Builder::_ending = sub {
        my $builder = shift;

        if ( $builder->{was_No_Plan} && $self->runner_plan =~ /\d+/ ) {
            $builder->expected_tests( $self->builder->{Expected_Tests} );
            $builder->no_header( 1 );
        }

        return $builder->$original_sub( @_, );
    };
}

=head1 AUTHOR

Justin DeVuyst, C<[e-mail]>

=head1 COPYRIGHT AND LICENSE

Copyright 2009 by Justin DeVuyst.

This library is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;