view release on metacpan or  search on metacpan

lib/Agent/TCLI/Transport/Test.pm  view on Meta::CPAN

The Agent::TCLI::Transport::Test module is a bridge between the rest of the TCLI
system and Perl's TAP based testing system. This module uses Test::Builder
underneath and should be compatible with all other Test modules that use
Test::Builder.

The one cautionary note is that Agent::TCLI::Transport::Test runs on top of POE
which is an asynchronous, event based system. Typically, tests will not
complete in the order that they are written. There are various means to
establish control over the completion of prior tests which should be
sufficient for most cases. However, one should not write a test script
without some thought to the ordering needs of the tests and whether extra
tests need to be in place to ensure those needs are met.

=head1 GETTING STARTED

If you are unfamiliar with Perl's Test:: modules, then please see
L<Test::Tutorial> for background information.

One may look at some of the test scripts with the TCLI source for examples,
but they are limited to a single agent.
The TCLI core does not come with modules that are useful for multi-agent test
scripts. This is to reduce the dependencies for the Core. Please see example
scripts provided with other TCLI packages for better multi agent examples.

Currently, Agent::TCLI::Transport::Test offers only an object interface, so we're
using Test::More to set the plan and import diag() into the test script.
This might change at some point, but this kludge will always work.

As in the Synopsis, one will most often want to define the necesary packages
outside of the transport(s) used. Typically one will want the same packages
loaded in all the transports. By same, we mean the same package object
instantiations.

One then needs to create the Agent::TCLI::Transport::Test object. The Synoposis covers
the typical parameters set on creation. All of the Agent::TCLI::Transport::Test
class mutator methods are available within new, but generally should not be used.
There may be other inherited mutator methods from Agent::TCLI::Transport::Base that
could be useful.

Unlike other Transports, users do not have to be defined
for Transport::Test, as it will load a default user. Local tests are
executed with a Control created for the first user in the stack. Currently,
running with users other than the default has not been tested.

Then one needs to create at least one Agent::TCLI::Testee. The testee
object will be used for the actual tests. See Agent::TCLI::Testee
for the tests available.

Within the actual tests, the Agent::TCLI::Transport::Test (as test_master) offers two
flow/control commands. B<run> is necesary at the end of the tests to start
POE completely and finish the tests. B<done> may be used within the script
to force check for completion of all prior tests. B<done> is a test itself and
will report a success or failure.

=head2 ATTRIBUTES

Unless otherwise indicated, these attrbiute methods are for internal use. They are not
yet restricted because the author does not beleive his imagination is better
than the rest of collective world's. If there are use cases for accessing
the internals, please make the author aware. In the future, they may be
restricted to reduce the need for error checking and for security.

=over

=cut

use warnings;
use strict;

use vars qw($VERSION @EXPORT %EXPORT_TAGS );

use Carp;
#use Time::HiRes qw(time);

use POE;
use Agent::TCLI::Control;
use Agent::TCLI::Request;
use Agent::TCLI::User;
require Agent::TCLI::Transport::Base;

use Test::Builder::Module;

use Object::InsideOut qw( Agent::TCLI::Transport::Base Test::Builder::Module);

our $VERSION = '0.031.'.sprintf "%04d", (qw($Id: Test.pm 62 2007-05-03 15:55:17Z hacker $))[2];

#func#our $TCLI_TEST = Agent::TCLI::Transport::Test->new;

#func#BEGIN {
#func#	@EXPORT = qw( load_packages
#func#		is_body like_body
#func#		is_code like_code
#func#		);
#func#}

=item testees

An array of the testees that the test transport will be working with.

=cut

my @testees			:Field
					:All('testees')
					:Type('Array');

=item requests

An internal array acting as a queue of the requests to send. Requests are not
retained in the queue, but are only held until dispatched.

=cut
my @requests		:Field
					:All('requests')
					:Type('Array');

=item test_count

A running count of all the tests. Some requests may contain multiple tests.
B<test_count> will only contain numeric values.

=cut

lib/Agent/TCLI/Transport/Test.pm  view on Meta::CPAN

		")\n\t test($test) input($input)\n\t exp($exp1)",1);
	my ($request, $id);

	if ( ( defined($input) && $input ne '') )
	{
		# check if input is a request object.
		if ( ref($input) =~ /Request/ )
		{
			# verify sender/postback
			if ( ( $request->postback->[0] eq 'PostRseponse' &&
				   $testee->addressee ne 'self' ) ||
				 ( defined($request->postback->[1] ) &&
				   $request->postback->[1] ne $testee->addressee )
			)
			{
				croak("Testee $testee->addressee does not match request" );
			}
			$request = $input;
			$id = $request->id;
		}
		else # put into default request if not
		{
			# clone the default_request
			$request = $self->default_request->clone(1);
			$request->input($input);

			# Insert the proper testee
			if ($testee->addressee ne 'self')
			{
				$request->sender([
					$testee->transport,
					$testee->protocol,
					]);
				$request->postback([
					'PostRequest',
					$testee->addressee,
				])
			}

			# using make_id to faciltate changing ID style in olny one place later
			$request_count[$$self]++;
			$id = $self->make_id( $request_count[$$self]);
			$request->id( $id );

			# Put request onto stack.
			$self->push_requests($request);

			$last_testee[$$self] = $testee->addressee;

		}
	}
	else
	{
		croak("Input required. Nothing in queue") unless defined($request_count[$$self]);
		# Get last request id if none provided
		$id = $self->make_id( $request_count[$$self] );
	}

	unless ( defined $name )
	{
		$name = ( $test =~ qr(not|error) )
			? 'failed '.$input
			: $input;
	}

	$test_count[$$self]++;

	# add test, values, name and number to request_tests.
	# Not doing any checking, so allowing stupidity like repeating tests
	# or putting in conflicting tests....
	push( @{$self->request_tests->{ $id } },
		[ $test, $exp1, $exp2, $name, $test_count[$$self] ] );

	$self->dispatch;

	# return request for future reference.
	return($request);
}

=item dispatch

This internal object method is used to dispatch requests and run POE timeslices
during the test script. An understanding of POE may be necessary to grok
the need for this function.

=cut

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

	# Clean out anything in kernel queue
	$poe_kernel->run_one_timeslice;

	my $post_it = $self->post_it($style);

	if ( ( $post_it == 1 ) && ( my $next_request = $self->shift_requests ) )
	{
		$self->Verbose($self->alias.":dispatch: sending request id(".$next_request->id.") " );
		$poe_kernel->post($self->alias, 'SendRequest', $next_request );

		# There are problems with OIO Lvalues on some windows systems....
		$requests_sent[$$self]++;

		# Go ahead and send that out
		$poe_kernel->run_one_timeslice;

		# But wait, are there more?
		$self->dispatch if ( $self->depth_requests );
	}

	# returning $post_it so that it can be checked to see if it is safe to proceed.
	# This could be used by done() to loop until timed out.
	$self->Verbose($self->alias.":dispatch: post_it($post_it)",2);

	return($post_it);
}

=item do_test

This is an internal method to process responses.
B<do_test> actually executes the test and send the output to the TAP processor.
It takes an ARRAYREF for the test and the Agent::TCLI::Response to be checked as
parameters.

=cut

sub do_test {
	my ($self, $t, $response) = @_;

	# Split out test name and test class.
	my ($test, $class) = split('-',$t->[0]);

	my $value;
	my $another = 0;
	my $again = 0;
	# Test classes currently, body, code, time

	if ($class eq 'time')
	{
		# Should time be checked on the first test or on the last?
		# Time will get checked wherever it is placed in the queue
		# before a body/code and is tested agaisnt that response time.
		$value = int( time() ) - $response->get_time();
		# time does not use up a response.
		$another = 1;
	}
	elsif ($class eq 'fail')
	{
		# Got nothing, test nothing.
		$value = '';
	}
	else
	{
		$value = $response->$class();
	}
	# $t is [ test-class , expected, expected2, name ]

    # special case for code 100 / class code
    # Preserves and skips all tests if a 100 is received and not looking
    # for it.
    if ( $class eq 'code' && $value == 100 && $t->[1] != 100 )
    {
    	# skip the test unless testing for 100
		$self->Verbose($self->alias.":do_test: $class value($value) != $t->[1] skipping ");
		# Preserve this test
		$again = 1;
		# skip the rest of the tests for this response too.
    	return ($another, $again);
    }

	my $res;
	# Let's do it.
	$self->Verbose($self->alias.
		":do_test: $test $class value($value) expected(".$t->[1].") ");

	if ($test =~ qr(eq|num|like) )
	{
		$res = $self->builder->$test( $value, $t->[1], $t->[3] );
		$self->builder->diag($response->body) if (!$res && $class eq 'code');
	}
	elsif ($test =~ qr(error) )
	{
		$res = $self->builder->ok( ( $value >= 400 && $value <= 499 ) , $t->[3] );
		$self->builder->diag($response->body) if (!$res);
	}
	elsif ($test =~ qr(success) )
	{
		$res = $self->builder->ok( ( $value >= 200 && $value <= 299 ) , $t->[3] );
		$self->builder->diag($response->body) if (!$res);
	}
	elsif ($test =~ qr(trying) )
	{
		$res = $self->builder->ok( ( $value >= 100 && $value <= 199 ) , $t->[3] );
		$self->builder->diag($response->body) if (!$res);
	}

	if ($test =~ qr(^are) )
	{
		# set again not to use up this test on this resonse
		$again = 1;
	}

	$self->Verbose($self->alias.
		":do_test: $test res($res) another($another) again($again)");

	return ($another, $again);
}

=item get_param ( <param>, [ <id>, <timeout> ] )

B<get_param> is an internal method that supports the Testee get_param command.
It requires a param argument that is the parameter to try and obtain a value
for. It takes an optional request id from a prior request. If not
supplied, it will use the last request made. It also takes an optional
timeout value, which will be passed to B<done_id>
to wait for all responses to that request to come in.

B<get_param> attempts to parse the text in the responses to find the value
for the parameter being requested. It expects that the response is
formatted appropriately to extract the parameter.
Valid formats to receive the parameter are:
	 param=something
	 param something
	 param="a quoted string with something"
	 param "a quoted string with something"
	 param: a string yaml-ish style, no comments, to the end of the line
	 param: "a quoted string, just what's in quotes"
It returns the value of the parameter requested, or undefined if it
cannot be found.

=cut

sub get_param {
	my ($self, $param, $id, $timeout) = @_;

	# valid formats to receive the parameter are:
	# param=something
	# param something
	# param="a quoted string with something"
	# param "a quoted string with something"
	# param: a string yaml-ish style, no comments, to the end of the line