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

Test-Able documentation Contained in the Test-Able distribution.

Index

Code Index:

NAME

Top

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

DESCRIPTION

Top

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

ATTRIBUTES

Top

method_types

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

*_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 Test::Able::Method::Array objects just for the convenience of overloading for hash access. The elements of the lists will be Test::Able::Role::Meta::Method-based method metaclass objects.

test_objects

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

current_test_object

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

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.

current_method

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

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.

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.

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.

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 Test::Able::FatalException exception.

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

METHODS

Top

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.

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.

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.

build_all_methods

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

clear_all_methods

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

log

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

clear_plan

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

AUTHOR

Top

Justin DeVuyst, justin@devuyst.com

COPYRIGHT AND LICENSE

Top

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.

Test-Able documentation Contained in the Test-Able distribution. 
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 );


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


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' ); };


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


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


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


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


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


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


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',
);


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

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


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 { []; }


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


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


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'
    );
}


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


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


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


#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( @_, );
    };
}


1;