view Lib/IMPL/Test/Unit.pm @ 134:44977efed303

Significant performance optimizations Fixed recursion problems due converting objects to JSON Added cache support for the templates Added discovery feature for the web methods
author wizard
date Mon, 21 Jun 2010 02:39:53 +0400
parents 964587c5183c
children f8de52d3c112
line wrap: on
line source

package IMPL::Test::Unit;
use strict;
use warnings;

use base qw(IMPL::Object);
use IMPL::Class::Property;

use Time::HiRes qw(gettimeofday tv_interval);

use Error qw(:try);
use Carp qw(carp);
use IMPL::Test::Result;
use IMPL::Test::FailException;
use IMPL::Exception;

BEGIN {
    public property Name => prop_all;
    public property Code => prop_all;
}

sub CTOR {
    my ($this,$info) = @_;
    
    die new IMPL::InvalidArgumentException("TestInfo should be supplied as an argument") unless $info;
    
    $this->Name($info->Name || 'Annon');
    $this->Code($info->Code)or die new IMPL::InvalidOperationException("Can't create test without entry point");
}

sub UnitName {
    my ($self) = @_;
    $self->toString;
}

sub Setup {
    1;
}

sub Cleanup {
    my ($this,$session) = @_;
    
    $session->{$_} = $this->$_() foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData',undef,1);
    
    1;
}

sub StartUnit {
    my $class = shift;

    return {};
}

sub InitTest {
    my ($this,$session) = @_;
    
    $this->$_($session->{$_}) foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData',undef,1);
}

sub FinishUnit {
    my ($class,$session) = @_;
    
    1;
}

sub List {
    my $self = shift;
    
    return $self->get_meta('IMPL::Test::Unit::TestInfo',undef,1); # deep search with no criteria
}

sub Run {
    my ($this,$session) = @_;
    
    my $t = [gettimeofday];
    return try {
        $this->InitTest($session);
        $this->Setup;
        my $code = $this->Code;
        
        
        my $t0 = [gettimeofday];
        my $elapsed;
        
        try {
            $this->$code();
            $elapsed = tv_interval ( $t0 );
        } finally {
            # we need to call Cleanup anyway
            $this->Cleanup($session);
        };
        
        return new IMPL::Test::Result(
            Name => $this->Name,
            State => IMPL::Test::Result::SUCCESS,
            TimeExclusive => $elapsed,
            TimeInclusive => tv_interval ( $t )
        );
    } catch IMPL::Test::FailException with {
        my $e = shift;
        return new IMPL::Test::Result(
            Name => $this->Name,
            State => IMPL::Test::Result::FAIL,
            Exception => $e,
            TimeInclusive => tv_interval ( $t )
        );
    } otherwise {
        my $e = shift;
        return new IMPL::Test::Result(
            Name => $this->Name,
            State => IMPL::Test::Result::ERROR,
            Exception => $e,
            TimeInclusive => tv_interval ( $t )
        );
    }
}

package IMPL::Test::Unit::TestInfo;
use base qw(IMPL::Object::Meta);
use IMPL::Class::Property;

require IMPL::Exception;

BEGIN {
    public property Name => prop_all;
    public property Code => prop_all;
}

sub CTOR {
    my ($this,$name,$code) = @_;
    
    $this->Name($name);
    $this->Code($code) or die new IMPL::InvalidArgumentException("The Code is a required parameter");
}

package IMPL::Test::Unit::SharedData;
use base qw(IMPL::Object::Meta);
use IMPL::Class::Property;

BEGIN {
    public property DataList => prop_all | prop_list;
}

sub CTOR {
    my $this = shift;
    
    $this->DataList(\@_);
}
1;