style results from the CPAN

Agent-TCLI


	# Load up control now, before requests come in, since we must be local
	# if loading packages.
	# Get a Control for the test-master user loaded into peers.
	$self->GetControl(	$self->peers->[0]->id, $self->peers->[0] );

	# Get the packages and control going but come back for the requests.
	$poe_kernel->run_one_timeslice;
}

=item build_test

This object method is used to build the test, as a Agent::TCLI::Request, and put it
on the queue. It is called by the Testee. Some of this functionality may be
pushed to the Testee soon, so expect this API to change.

=cut

sub build_test {
	my ($self, $testee, $test, $input, $exp1, $exp2, $name) = @_;
	$self->Verbose($self->alias.":build_test: testee(".$testee->addressee.
		")\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();

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

		$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
	# param: "a quoted string, just what's in quotes"

	my $value;

	# validate id
	unless ( defined($id) && $id )
	{
		# Use last id if not supplied
		$id = $self->make_id( $request_count[$$self]);
	}

	$self->Verbose("get_param: param($param) id($id) timeout($timeout)  ",1);

	$self->done_id( $id, $timeout) if ( defined($timeout) );

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

	$self->Verbose("get_param: id($id) timeout($timeout) count(".
		@{ $self->responses->{$id} }.") ",2);

	# loop through responses, last first
	RESPONSE: foreach my $response ( reverse @{$self->responses->{$id}} )
	{
		$self->Verbose('get_param: body('.$response->body.') ',3);

		# any valid format in double quotes
		if (  $response->body =~ qr($param(?:=|\s|:\s)"(.*?)") )
		{
			$value = $1;
			last RESPONSE
		}
		# = or space followed by a word
		elsif ( $response->body =~ qr($param(?:=|\s)(\S*))  )
		{
			$value = $1;
			last RESPONSE
		}
		# yaml to the end of the line
		elsif ( $response->body =~ qr($param(?::\s)(.*?)\s*$)m )
		{
			$value = $1;
			last RESPONSE
		}

	}
	$self->Verbose("get_param: returning $value");
	return ($value);
}

=item get_responses ( [ <id>, <timeout> ] )

B<get_responses> is an internal method that supports the Testee get_responses
command. 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> to wait for all responses
to come in.
It returns the text from all available responses, separated by a pair
of newlines.

=cut


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

	my $value;

	# validate id
	unless ( defined($id) && $id )
	{
		# Use last id if not supplied
		$id = $self->make_id( $request_count[$$self] );
	}
	$self->Verbose("get_responses: id($id)",3);

	$self->done_id( $id, $timeout) if ( defined($timeout) );

	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 0.877 second using v1.01-cache-2.11-cpan-99c4e6809bf )