Agent-TCLI
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
:Type('Numeric');
=item requests_complete
Number of requests_completed
B<requests_complete> will only accept Numeric type values.
=cut
my @requests_complete :Field
:All('requests_complete')
:Type('Numeric');
=item request_tests
A hash keyed by request ID of arrays of tests to perform on the responses
B<request_tests> will only contain hash values.
=cut
my @request_tests :Field
:Type('hash')
:Arg('name'=>'request_tests', 'default'=> { } )
:Acc('request_tests');
=item responses
A hash keyed on request_id to hold responses when multiple responses per request are expected.
B<responses> will only contain hash values.
=cut
my @responses :Field
:Type('hash')
:Arg('name'=>'responses', 'default'=> { } )
:Acc('responses');
=item responses_max_contiguous
This field hold a numeric value corellating to the response ID of the
maximum response received that had at least one response received
for all previous requests.
B<responses_max contiguous> will only contain numeric values.
=cut
my @responses_max_contiguous :Field
:Type('numeric')
:Arg('name'=>'responses_max_contiguous', 'default'=> 1)
:Acc('responses_max_contiguous');
=item dispatch_counter
A running counter of Dispatch attempts to prevent stalling.
B<dispatch_counter> will only contain numeric values.
=cut
my @dispatch_counter :Field
:Type('numeric')
:All('dispatch_counter');
=item dispatch_retries
The number of times to retry the dispatching of queued requests. Increments are in 5 second blocks. Default is 6 or 30 seconds. This is a user adjustable setting.
When the count is reached, the next test is dispatched without regard to the state of the previous test.
The timeout will not start until dispatching is done or exceeded its retries. This allows for other requests to complete.
B<dispatch_retries> will only contain numeric values.
=cut
my @dispatch_retries :Field
:Type('numeric')
:Arg('name'=>'dispatch_retries','default'=>6)
:Acc('dispatch_retries');
=item timeout_counter
A running counter for timing out all requests.
B<timeout_counter> will only contain numeric values.
=cut
my @timeout_counter :Field
:Type('numeric')
:All('timeout_counter');
=item timeout_retries
The number of times to retry the timeout. Increments are in 5 second blocks. Default is 6 or 30 seconds.
Timeout checks periodically to make sure we're still running requests. It begins the countdown when
all requests have been dispatched, so that we don't wait forever for something to complete. This is user adjustable.
B<timeout_retries> will only contain numeric values.
=cut
my @timeout_retries :Field
:Type('numeric')
:Arg('name'=>'timeout_retries','default'=>6)
:Acc('timeout_retries');
=item timeout_id
The id of the timeout event so that it can be rescheduled if necessary.
=cut
my @timeout_id :Field
# :Type('type')
:All('timeout_id');
=item running
A flag to indicate if we've started the POE kernel fully, rather than just running slices.
This is set when B<run> is called.
B<running> should only contain boolean values.
=cut
my @running :Field
# :Type('boolean')
:Arg('name'=>'running','default'=>0)
:Acc('running');
=item last_testee
Internally used when building a new test to check what the last testee was.
B<last_testee> will only contain scalar values.
=cut
my @last_testee :Field
# :Type('scalar')
:Arg('name'=>'last_testee','default'=>'')
:Acc('last_testee');
=item dispatch_id
Holds the POE event ID for the Dispatch so it can be rescheduled.
B<dispatch_id> should only contain scalar values.
=cut
my @dispatch_id :Field
# :Type('scalar')
:All('dispatch_id');
# Standard class utils are inherited
=back
=head2 METHODS
Most of these methods are for internal use within the TCLI system and may
be of interest only to developers trying to enhance TCLI.
The first three are the exception.
=over
=item done( <timeout>, <name> )
When B<done> is called, it will attempt to complete all previous requests before
continuing. If done is provided a name parameter, it will report its
results as a test. That is, it will pass if all previous tests are
completed before the timeout. In either case, it will return true if all tests
are complete and false otherwise.
It takes an optional timeout parameter, an integer in seconds. The default timeout
is 31 seconds if none is supplied.
It takes an option parameter of a test name.
=cut
sub done {
my ($self, $wait, $name) = @_;
$wait = 31 unless defined $wait;
my $start = time();
my $ready = 0;
$self->Verbose($self->alias.":done: start($start) wait($wait)");
# Clean out anything in kernel queue
# $poe_kernel->run_one_timeslice unless ($self->running || $wait == 0 );
# Try to finish up anything left out there.
while ( $start + $wait > time() )
{
$self->Verbose($self->alias.":done: end(".($start + $wait).")time(".time().") ",3);
# make sure there is nothing in request queue
$self->dispatch;
$ready = $self->post_it('done');
# Clean out anything in kernel queue
$poe_kernel->run_one_timeslice;
last if $ready;
next;
}
$ready = $self->post_it('done') if ($wait == 0);
if ( (not $ready && $wait == 0 ) ||
($ready && $wait > 0 ) )
{
$self->Verbose($self->alias.":done: ".
" run(".$self->running.") dc(".$dispatch_counter[$$self].") dr(".
$dispatch_retries[$$self].") tc(".$timeout_counter[$$self].") tr(".
$timeout_retries[$$self].") requests(".$self->depth_requests.") ");
$self->Verbose($self->alias.":done: count(".$request_count[$$self].
") contiguous(".$self->responses_max_contiguous.")");
}
# there may be tests left in request_tests.
# Some will be all type tests (ares...), which do not matter.
# but some will need to be failed.
my $test;
ID: foreach my $id ( sort keys %{$self->request_tests} )
{
# are there more tests left for this request?
next ID unless ( scalar(@{$self->request_tests->{ $id } } ) > 0);
TEST: while ( @{ $self->request_tests->{ $id } } )
{
$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 done_id(<id>, <timeout>, <name> )
B<done_id> works similarly to B<done> except that it waits only for the
results from one request, as specified by the id. If a request id is not
supplied, it will default to the last request made.
It takes an optional timeout parameter, an integer in seconds. The default timeout
is 31 seconds if none is supplied.
It takes an option parameter of a test name.
=cut
sub done_id {
my ($self, $id, $wait, $name) = @_;
$wait = 31 unless defined $wait;
my $start = time();
my $ready = 0;
# validate id
unless ( defined($id) && $id )
{
# Use last id if not supplied
$id = $self->make_id( $request_count[$$self] );
}
$self->Verbose($self->alias.":done_id: id($id) start($start) wait($wait)",1);
# Clean out anything in kernel queue
# $poe_kernel->run_one_timeslice unless ($self->running || $wait == 0 );
# Try to finish up anything left out there.
while ( $start + $wait > time() )
{
$self->Verbose($self->alias.":done_id: end(".($start + $wait).") time(".time().") ",3);
# make sure there is nothing in request queue
$self->dispatch;
$ready = $self->post_it('done');
# Clean out anything in kernel queue
$poe_kernel->run_one_timeslice;
last if $ready;
next;
}
$ready = $self->post_it('done') if ($wait == 0);
if ( (not $ready && $wait == 0 ) ||
($ready && $wait > 0 ) )
{
$self->Verbose($self->alias.":done: ".
" run(".$self->running.") dc(".$dispatch_counter[$$self].") dr(".
$dispatch_retries[$$self].") tc(".$timeout_counter[$$self].") tr(".
$timeout_retries[$$self].") requests(".$self->depth_requests.") ");
$self->Verbose($self->alias.":done: count(".$request_count[$$self].
") contiguous(".$self->responses_max_contiguous.")");
}
# there may be tests left in request_tests.
# Some will be all type tests (ares...), which do not matter.
# but some will need to be failed.
my $test;
TEST: while ( @{ $self->request_tests->{ $id } } )
{
$test = shift @{ $self->request_tests->{ $id } };
# if this is an multi response test, then skip it
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
$self->Verbose($self->alias.":SendRequest: request dump \n",3,$request);
# send request
# Need to think about sender stack...
# if there is nothing on the stack, it get's populated with
# test and posted to control.
# if another transport is on the stack, it puts itself on the bottom?
# Then sends it to the local transport for handling.
# The local transport will send it to the remote transport, putting
# itself (the local) on the stack as well. No, it needs to take off the remote when it sends it there.
# we're not via headers here. We just need to know where to go
# Transport should take themselves out and put in where they got the request
# so it can go back.
# Put time in request for tracking
$request->set_time(time());
if ( $request->sender->[0] eq $self->alias )
{
$self->Verbose($self->alias.":SendRequest: local request \n");
$self->Verbose($self->alias.":SendRequest: request dump ".$request->dump(1),3 );
# Get a Control for the test-master user loaded into peers.
my $control = $self->GetControl( $self->peers->[0]->id, $self->peers->[0] );
# Post to our Control
# Sometimes, control has not started, so we wiat if we have to.
if ( defined($control->start_time) )
{
$kernel->post( $control->id => 'Execute' => $request );
}
else
{
$kernel->delay('ControlExecute' => 1 => $control, $request );
}
}
else
{
$self->Verbose($self->alias.":SendRequest: punting the request \n");
# Take off Sender and postback and put us at the end.
# assuming here that wherever this is going, we don't have to
# worry about setting up the Control....
my $sender = $request->shift_sender;
my $postback = $request->shift_postback;
$request->push_sender($self->alias);
$request->push_postback('PostResponse');
$kernel->call( $sender => $postback => $request );
}
return( );
}
=item Timeout
B<Timeout> is a POE event handler that makes sure that a test script completes
and no requests leave the system waiting too long for a response. It takes
an argument of the delay, in seconds, that it will wait until checking again.
=cut
sub Timeout {
my ($kernel, $self, $session, $delay, ) =
@_[KERNEL, OBJECT, SESSION, ARG0, ];
$self->Verbose($self->alias.":Timeout: {".$delay.
"} run(".$self->running.") dc(".$dispatch_counter[$$self].") dr(".
$dispatch_retries[$$self].") tc(".$timeout_counter[$$self].") tr".
$timeout_retries[$$self].") requests(".$self->depth_requests.") ");
# Is Dispatch done with the queue?
# We wait until running before using an empty queue as goood enough.
if ( ( $self->running && $self->depth_requests == 0 ) ||
$dispatch_counter[$$self] == $dispatch_retries[$$self] )
{
if ( $request_count[$$self] == $requests_complete[$$self] ||
$timeout_counter[$$self] == $timeout_retries[$$self] )
{
$kernel->yield('_shutdown');
return;
}
else
{
$kernel->delay( 'Timeout', $delay, $delay, );
$timeout_counter[$$self]++;
}
}
# Dispatch now taking care of requests still in queue and we'll just wait until
# it is done.
else
{
$kernel->delay( 'Timeout', $delay, $delay, );
}
}
=item GetControl ( id )
Inherited from Agent::TCLI::Trasnport::Base
=cut
=item _shutdown
Shutdown begins the shutdown of all child processes.
=cut
sub _shutdown :Cumulative {
my ($kernel, $self, $session) =
@_[KERNEL, OBJECT, SESSION];
$self->Verbose($self->alias.':_shutdown:');
foreach my $package ( @{$self->control_options->{'packages'} })
{
$kernel->post( $package->name => '_shutdown' );
}
# $kernel->alias_remove( $self->alias );
return ('_shutdown '.$self->alias )
}
sub _start {
my ($kernel, $session, $self) = @_[KERNEL, SESSION, OBJECT];
# Trying to run this as cumulative is not working. Not sure why.
# Just being inefficient instead of debugging.
# are we up before OIO has finished initializing object?
if (!defined( $self->alias ))
{
$self->Verbose($session->ID.":_start: OIO not started delaying ");
$kernel->yield('_start');
return;
}
$kernel->alias_set($self->alias);
$self->Verbose($self->alias.":_start: Starting alias(".$self->alias.")");
# Set up recording.
$self->requests_sent(0) ;
$self->requests_complete(0);
# initialize counters
$self->dispatch_counter(0);
$self->timeout_counter(0);
# This will call timeout in 5 seconds
# So there is a 30 seconds delay from the sending of the last test
# before we stop by default.
$timeout_id[$$self] = $kernel->delay_set( 'Timeout', 5, 5 );
# well, tha above would be true if the kernel was running gung ho. But we're
# calling timeslices willy nilly until all requests are queued, so it turns out
# that Timeout gets called in every timeslice regardless of delay, but
# this is good because it is the one queud event that keeps everything
# from stopping.
# When debugging POE Event streams, this might help.
return('_start'.$self->alias);
}
=item _stop
This POE event handler is called when POE stops a Transport.
=cut
sub _stop {
my ($kernel, $session, $self) = @_[KERNEL, SESSION, OBJECT];
$self->Verbose($self->alias.":".":stop session stopped...\n" );
# did we send all requests?
$self->builder->is_num( $self->depth_requests, 0,
$self->alias." test queue empty" );
$self->done(0,"Run finished, all tests completed");
# Sometime timeout is sneaking itself back onto stack during shutdown.
$self->Verbose($self->alias.":_stop: removing alarms",1,$kernel->alarm_remove_all() );
# TODO maybe hold on on all response count tests until done for overages?
# When debugging POE Event streams, this might help.
return('_stop '.$self->alias);
}
1;
#__END__
=back
=head1 AUTHOR
Eric Hacker hacker can be emailed at cpan.org
=head1 BUGS
There is no separation between users running tests, which means it
could be very ugly to have multiple users try to run tests on one TCLI Agent.
Test scripts not thorough enough.
Probably many others.
=head1 LICENSE
( run in 1.088 second using v1.01-cache-2.11-cpan-6aa56a78535 )