view release on metacpan or  search on metacpan

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

	{
		$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) )

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

		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