synchro results from the CPAN

Agent-TCLI

# $Id: Test.pm 62 2007-05-03 15:55:17Z hacker $
package Agent::TCLI::Transport::Test;

=pod

=head1 NAME

Agent::TCLI::Transport::Test - transport for testing commands

=head1 SYNOPSIS

	use Test::More qw(no_plan);
	ues Agent::TCLI::Transport::Test;
	use Agent::TCLI::Package::Tail;

	# set the list of packages
	my @packages = (
		Agent::TCLI::Package::Tail->new({
			'verbose'		=> \$verbose,
			'do_verbose'	=> sub { diag( @_ ) },
		}),
	);


	my $test_master = Agent::TCLI::Transport::Test->new({
	    'verbose'   	=> \$verbose,        # Verbose sets level

	    # change verbose output to Test::More::diag
		'do_verbose'	=> sub { diag( @_ ) },

		# load up the packages to support testing
	    'control_options'	=> {
		    'packages' 		=> \@packages,
	    },
	});

	# need at least one testee

	# Set up the local test
	my $target = Agent::TCLI::Testee->new(
		'test_master'	=> $test_master,
		'addressee'		=> 'self',
	);

=head1 DESCRIPTION

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;

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

	{
		$test = shift @{ $self->request_tests->{ $id } };
		# if this is an multi response test, then skip it
		if ( $test->[0] =~ qr(are) )
		{
			next TEST;
		}

		# any other test must fail if there is no response

		$self->builder->ok( 0, $test->[3] );
		$self->builder->diag("Response not recieved for this test's request.");

	}

	if ( defined($name) && $name ne '' )
	{
		$test_count[$$self]++;
		$self->builder->ok( $ready, $name );
	}
	$self->Verbose($self->alias.":done: ready($ready) ");

	return ($ready);
}


=item load_testee ( <testee> )

The preferred way to load a testee is to set 'test_master' when the testee is
created. Testee will then call this function on initializtion. A testee is
an Agent::TCLI::Testee object.

=cut

sub load_testee {
	my ($self, $testee) = @_;
#func#	my $self = ( ref $_[0] && (ref $_[0]) =~ /Agent::TCLI::.*TEST/ )
#func#		? shift : $TCLI_TEST;
	$self->Verbose($self->alias.":load_testee: dump ".$testee->dump(1),3);

	$self->push_testees($testee);
}

=item run

B<run> is called at the end of the test script. It will call POE::Kernel->run
to finish off all of the requests. Other POE event handlers will ensure that all
queued requests are dispatched and all requests dispatched are completed.

Running does not take any parameters and does not return anything.

=cut

sub run {
	my $self = shift;
	$self->Verbose($self->alias.":run: running (".$self->depth_requests.") requests " );

	# requests still left in queue (How could there not be?)
	if ( $self->depth_requests > 0 )
	{
		# Whatever's left in the queue is bigger than us little synchronous
		# calls. Send it over to the big Dispatch.
		$poe_kernel->post($self->alias, 'Dispatch', 1 );
	}

	# set running state for Timeout.
	$self->running(1);

	$poe_kernel->run;
}

=item preinit

This private Object::InsideOut (OIO) method is used for object initialization.

=cut

sub _preinit :PreInit {
	my ($self,$args) = @_;

	$args->{'alias'} = 'transport_test' unless defined( $args->{'alias'} ) ;

  	$args->{'session'} = POE::Session->create(
        object_states => [
        	$self => [ qw(
	            _start
            	_stop
        	    _shutdown
        	    _child
        	    _default

				Dispatch
        	    SendChangeContext
        	    SendRequest

				PostResponse
        	    Timeout
        	)],
        ],
  	);

	$args->{'peers'} = [ Agent::TCLI::User->new({
		'id'		=> 'test-master@localhost',
		'protocol'	=> 'test',
		'auth'		=> 'master',
	})] unless defined($args->{'peers'});

	$args->{'do_verbose'} = sub { diag( @_ ) } unless defined($args->{'do_verbose'});

}

=item _init

This private OIO method is used for object initialization.

=cut

sub _init :Init {
	my ($self, $args) = @_;

	$self->set(\@default_request, Agent::TCLI::Request->new({

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

	return(undef) unless (exists( $self->responses->{$id} ) );

	$self->Verbose("get_responses: id($id) count(".@{ $self->responses->{$id} }.") ",1);
	# loop through responses
	RESPONSE: foreach my $response ( reverse @{ $self->responses->{$id} } )
	{
		$value .= $response->body."\n\n";
	}
	$self->Verbose("get_responses: returning $value");
	return ($value);
}

=item make_id

B<make_id> is used to create a request ID for new requests. It is a separate
method to ease mainenance in case it needs to change in the future. It
takes an optional integer as a parameter, or will default to the current
request_count.

=cut

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

	my $id = defined ($num) ? $num : $self->request_count;

	# Maybe put in hostname and PID or some other unique ID prefix someday?
	# or maybe not

	$self->Verbose($self->alias.":make_id: num($num) id($id)",2);
	return ( $id );
}

=item post_it

This internal method controls whether to dispatch the next test. It supports
different styles of running tests, though currently the style is not
user configurable and manipulation of the style is not tested.

For future reference and to encourage assistance in creating a user interface to style, they are:

B<default> or B<syncsend> - This allows a test to be dispacthed when the
acknoledgement is received that the previous test has been received OK. This
does not wait for the previous test to complete.

B<syncresp> or B<done> - This will not dispatch any test until the previous test
has completed. There are many testing scenarios where this makes no sense.
There may be scenarios where it does make sense, and htat is why it is here.
A similar effect can be had with the B<done> test.

B<asynch> - This dispatches a test as soon as it is ready to go. Sometimes
this may allow a local test to complete before a prior remote test has
been acknowledged, so it is not the default.

=cut

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

	# Currently running partially synchronous by default.
	$style = 'default' unless defined( $style );

	# TODO Option to set default for all runs.
	if ( $dispatch_counter[$$self] == $dispatch_retries[$$self] )
	{
		# if we stalled on something, then skip it
		$post_it = 1;
	}
	elsif ( !defined($style) || $style =~ /default|syncsend/ )  # partially synchronous / ordered
		# make sure we got some response to the previously sent request before sending
	{
		# Have we seen a response yet for the last request?
		$self->Verbose($self->alias.":post_it:$style: sent(".$requests_sent[$$self].") ",1);
		if ( $requests_sent[$$self] == 0 ||
			exists( $responses[$$self]{ $self->make_id($requests_sent[$$self]) } )
		)
		{
			$post_it = 1;
		}
	}
	elsif ( $style =~ /syncresp|done|ordered/ )  # completely synchronous / ordered
		#make sure all created requests have responses before sending another
	{
		my $rmc = $self->responses_contiguous;
		if ( $request_count[$$self] == $rmc )
		{
			$post_it = 1;
		}
		$self->Verbose($self->alias.":post_it:$style: count(".
			$request_count[$$self].") contiguous(".$rmc.")",);
	}
	elsif ( $style =~ /async/  )  # asynchrounous, no other checks necessary
		# who cares, send it now.
	{
			$post_it = 1;
	}
	$self->Verbose($self->alias.":post_it: ($post_it)");
	return($post_it);
}

=item responses_contiguous (   )

Sets responses_max_contiguous correctly by starting at the last value and
incrementing until a response has not been recived. Return
responses_max_contiguous.

=cut

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

	while  ( defined($self->responses->{
		$self->make_id( $self->responses_max_contiguous + 1) } ) )
	{
		$responses_max_contiguous[$$self]++;
	}
	return ( $self->responses_max_contiguous );
} # End responses_contiguous

=item Dispatch

This POE event handler takes care of dispatching once POE is running fully.
It maintains a counter to ensure that the test queue does not become stuck.
If the counter is exceeded (the queue is stuck), it will send a test without
regard to the response from B<post_it>.

=cut

sub Dispatch {
	my ($kernel,  $self, $session, $delay) =
  	  @_[KERNEL, OBJECT,  SESSION, 	   ARG0];
	$self->Verbose($self->alias.":Dispatch: {".$delay.
		"} dc(".$dispatch_counter[$$self].") requests(".$self->depth_requests.") ");

	my $next_request;

	if ( ! $self->depth_requests )
	{
		# Whohoo. we're done, let timeout know bu setting counter.
		$dispatch_counter[$$self] = $dispatch_retries[$$self];
	}
	elsif ( ( $self->post_it ) && ( $next_request = $self->shift_requests ) )
	{
		$self->Verbose($self->alias.":Dispatch: sending request id(".$next_request->id.") " ,1,);
		$kernel->yield( 'SendRequest', $next_request );

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

		# But wait, are there more?
		$kernel->delay('Dispatch', $delay, $delay);

( run in 1.210 second using v1.01-cache-2.11-cpan-d8267643d1d )