Agent-TCLI
view release on metacpan or search on metacpan
lib/Agent/TCLI/Control.pm view on Meta::CPAN
}
=item Execute
POE event Execute is the main event handler for incoming reuqests.
Transports should send command requests to Execute. The can be either
plain text as entered by the user or request objects.
Usage:
$kernel->post( 'Control' => 'Execute' => $input );
=cut
sub Execute {
my ($kernel, $self, $input) =
@_[KERNEL, OBJECT, ARG0];
$self->Verbose( "Execute: Input($input) ",2);
my (@args,$request);
# is input a request object or plaintext?
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# Here we need to extract the command for FindCommand
# Odds are the request doesn't have args or command populated
# if it was built outside of the Control.
if ( defined($request->args) )
# Hmm, someone thinks they're smarter than the Control at
# parsing. OK, we'll take that. Later we'll use the real args.
{
@args = reverse( @{$request->command} );
}
# add self to sender/postback stack so that we can put ourself
# into PostResponse to Transport to handle many contrls per transport
# Or should I just stuff that into the request at the Transport
# Well, what if there isn't a request yet at the transport?
# Either the request exists or it will come from the control....
# Or just make the stateful transports create a request...
# I think that is more elegant.
# Scratch all this.
}
$self->Verbose( "Execute: args",2,\@args);
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# # The command is broken down into a context, a command, and args.
# # The context helps find the command to execute and usually
# # remains the same between transactions unless changed by the user.
# # Context may be up to five layers deep. A single command may be
# # usable in more than one context, or even in all.
#
# # The command is sent as the first arg in @args.
#
# # Each command gets the following to execute:
# # $postback -> to send the response
# # \@args -> typically the user input in an array
# # $input -> the original user input
# # $thread -> the thread object for the user's session
# # The current context is stored in the $thread as an array but is
# # retrievable as a string as well.
#
# # Some commands merely establish context. Such as 'enable' in a Cisco
# # CLI. Though enable may require additional args. A default method/session
# # of the Agent::TCLI::Package::Base class called establish_context can handle
# # the simple case of setting context and confirming for the user.
lib/Agent/TCLI/Control.pm view on Meta::CPAN
$self->Verbose("Execute: Executing cmd(".$cmd->name.
") for ".$id[$$self]." \n");
# Now actually execute the command
if ( ref($request) =~ /Request/ )
{
if ( !defined($request->args) || $request->depth_args == 0 )
{
$request->args( \@args );
$request->command( $context );
$self->Verbose( "Execute: Request post FindCommand".$request->dump(1),3);
}
# The response may bypass the Control's AsYouWished, and go
# directly back to the Transport if that is what is $request(ed)
if ( $cmd->call_style eq 'sub')
{
# Subs can't handle request objects.
my (@rargs, $rinput);
# subs want the command in the @rargs
lib/Agent/TCLI/Control.pm view on Meta::CPAN
elsif ( $cmd->call_style eq 'state')
{
$self->Verbose("Execute: Executing state ".$cmd->handler." \n");
$kernel->yield( $cmd->handler => $request );
return;
}
elsif ( $cmd->call_style eq 'session')
{
$self->Verbose("Execute: Executing session ".$cmd->command.
"->".$cmd->handler." \n");
$kernel->post($cmd->command => $cmd->handler =>
$request );
return;
}
}
else
{
if ( $cmd->call_style eq 'sub')
{
($txt, $code) = $self->DoSub($cmd, \@args, $input );
}
else
{
my $request = Agent::TCLI::Request->new(
'args' => \@args,
'command' => $context,
'sender' => $self,
'postback' => 'AsYouWished',
'input' => $input,
'verbose' => $self->verbose,
'do_verbose' => $self->do_verbose,
);
if ( $cmd->call_style eq 'state')
{
$self->Verbose("Execute: Executing state ".$cmd->handler." \n");
$kernel->yield( $cmd->handler => $request );
return;
}
elsif ( $cmd->call_style eq 'session')
{
$self->Verbose("Execute: Executing session ".$cmd->command.
"->".$cmd->handler." \n");
$kernel->post($cmd->command => $cmd->handler =>
$request );
return;
}
}
}
}
unless ( defined($txt) )
{
$txt = 'Uh oh, Execute bombed';
lib/Agent/TCLI/Control.pm view on Meta::CPAN
'body' => $response,
'code' => 200,
);
}
# Is this what I want to do? Or should I Respond?
# The Control always acts directly as the interface between Transport
# and control is strictly defined. If we're here, there probably isn't a
# request object to respond to.
$self->Verbose( "AsYouWished: self dump \n",5,$self );
$kernel->post( $self->owner->session->ID => 'PostResponse' => $response, $self );
} #end sub control_AsYouWished
#sub control_err {
# my ($err, $msg) = @_;
# croak("ERROR: $err -> $msg \n");
#}
=item general
lib/Agent/TCLI/Package/Base.pm view on Meta::CPAN
sub SetControlKey {
my ($self, $control, $key, $value) = @_;
$controls[$$self]->{$control->id}{$key} = $value;
return
}
sub GetWheel {
my ($self, $id, $sp) = @_;
return ( $wheels[$$self]->{$id}{'wheel'},
$wheels[$$self]->{$id}{'sender'},
$wheels[$$self]->{$id}{'postback'} )
if (defined( $wheels[$$self]->{$id}{'wheel'}) && $sp );
return ( $wheels[$$self]->{$id}{'wheel'} )
if ( defined( $wheels[$$self]->{$id}{'wheel'} ) );
return (0);
}
sub SetWheel {
my ($self, $wheel) = @_;
lib/Agent/TCLI/Package/Tail.pm view on Meta::CPAN
'type' => $type,
));
# remove first-in line if total line count exceeded.
if ( $self->depth_line_cache > $self->line_max_cache )
{
$self->Verbose('Too many lines, removing...');
shift ( @{$self->line_cache} );
}
# post new event to active states
foreach my $state ( sort keys %{$self->active} )
{
$kernel->yield( $state => 'Append', $self->line_count );
}
}
=item Activate
This POE event handler activates tests in the queue by registering an
event with SimpleLog and creating an event handler.
lib/Agent/TCLI/Package/Tail.pm view on Meta::CPAN
$self->Verbose('Check: state('.$state.') lines('.$self->depth_line_cache.
') completed('.$self->tests_complete.') ',1);
$self->Verbose('Check: state('.$state.') test queue dump ',5,$self->test_queue );
# OK, so I actually had a bug where I created a Check event with no event name.
return unless defined ($state);
my $test = $self->test_queue->[$state -1];
$self->Verbose('Check: state('.$state.') test dump ',4,$test );
# Catch any events posted after this test completed
return if ( $test->complete );
# if ordered, make sure previous test has completed
# BUG This only works if all previous tests are ordered.
# Though it mostly does it right.
$self->Verbose('Check: ordered('.$test->ordered.') state('.$state.
') previous complete('.$self->test_queue->[$state - 2]->complete.
') complete('.$self->tests_complete.')',1);
if ( $test->ordered && ( $state > 1 ) &&
lib/Agent/TCLI/Package/Tail.pm view on Meta::CPAN
$because .= "Seen too many lines. Saw (".$test->line_count.") max(".
$test->max_lines.") passed(".$test->match_count.") \n".
"Last line: ".$input;
last LINE;
}
}
# if it passed, we took out the line, so don't increment.
$line_index++ unless($ok);
}
# $self->Verbose('Check: post loop state('.$state.') test dump ',2,$test );
# $self->Verbose('Check: post loop $ok('.$ok.') matchline',2,$matchline);
if ( ($test->match_times != 0) && ($test->match_count == $test->match_times) )
{
$kernel->call($self->name => 'Complete' => $state => 'ok' );
$test->complete(1);
}
# check clock and fail test if necessary
elsif ( ( $test->ttl != 0 ) && ( $time > $test->ttl ) )
{
$because .= "Timer expired. Time(".$time.") TTL(".$test->ttl.
lib/Agent/TCLI/Package/XMPP.pm view on Meta::CPAN
# break down args
return unless ( $param = $cmd->Validate($kernel, $request, $self) );
$self->Verbose("peer: param dump",4,$param);
my $user = Agent::TCLI::User->new($param
);
if ($user)
{
$kernel->post('transport_xmpp' => 'Peers' =>
$command,
$user,
$request
);
}
else
{
$request->respond($kernel, "peer $command failed ", 417);
}
lib/Agent/TCLI/Package/XMPP.pm view on Meta::CPAN
@_[KERNEL, OBJECT, SENDER, ARG0, ];
my $cmd = $self->commands->{'change'};
# break down args
return unless ( my $param = $cmd->Validate($kernel, $request, $self) );
$self->Verbose("change: param dump",4,$param);
$self->Verbose("settings: sending params to transport_xmpp",2);
$kernel->post('transport_xmpp' => 'Set' =>
$param => $request );
}
=item show
This POE event handler executes the show commands.
=cut
lib/Agent/TCLI/Package/XMPP.pm view on Meta::CPAN
# cmd1 attacks show <arg>
{
$what = $request->args->[0];
}
foreach my $attr ( keys %{$self->commands->{'show'}->parameters} )
{
if ( $what eq $attr || $what =~ qr(^(\*|all)$) )
{
$self->Verbose("show: sending show attr($attr) to transport_xmpp");
$kernel->post('transport_xmpp' => 'Show' => $attr =>
=> $request );
return;
}
else
{
$txt = "Can't display ".$attr
}
}
if (!defined($txt) || $txt eq '' )
lib/Agent/TCLI/Package/XMPP.pm view on Meta::CPAN
=cut
sub shutdown {
my ($kernel, $self, $sender, $request, ) =
@_[KERNEL, OBJECT, SENDER, ARG0, ];
$self->Verbose("shutdown: request ".$request->id );
$self->Verbose("shutdown: sending shutdown to transport_xmpp");
$request->Respond($kernel, "Shutting down transport_xmpp");
$kernel->post('transport_xmpp' => '_shutdown');
}
=item start
This POE event handler executes the start command. It is not exactly clear
when this would be useful currently, but we have a shutdown command and
balance must be maintained. Hopefully other transports will be available
in the future and this command might be more useful.
=back
=cut
sub start {
my ($kernel, $self, $sender, $request, ) =
@_[KERNEL, OBJECT, SENDER, ARG0, ];
$self->Verbose("start: request ".$request->id );
$self->Verbose("start: sending start to transport_xmpp");
$request->Respond($kernel, "Starting transport_xmpp");
$kernel->post('transport_xmpp' => '_start');
}
1;
#__END__
=head3 INHERITED METHODS
This module is an Object::InsideOut object that inherits from Agent::TCLI::Package::Base. It
inherits methods from both. Please refer to their documentation for more
lib/Agent/TCLI/Request.pm view on Meta::CPAN
and not externally accessible at this point.
=head1 OVERVIEW
Requests are the basic transaction in TCLI. In the simplest form, they are created by Control
for sending to the Command to perform the Request. Requests come with their own Respond
method that will generate a Response object, so that Commands do not need to implement that logic.
In the more complex form, Requests may be handled directly by Transports. Of course,
Transports do not process a Request, they merely move them. If a Transport if acting on a Request (or the Reponse)
it must have it's own logic for doing so. In order to facilitate this process, sender and postback attrbutes
are arrays, so that they may be stacked. The Respond method will remove the entries from the stack.
=cut
use warnings;
use strict;
#use Carp;
use Object::InsideOut qw(Agent::TCLI::Base);
use Agent::TCLI::Response;
lib/Agent/TCLI/Request.pm view on Meta::CPAN
=item sender
The POE session making the request, so that the response can be returned
properly. It is also the Tranport used when going between agents.
=cut
my @sender :Field
:All('sender')
:Type('ARRAY' );
=item postback
The event to post the response back to. It is also the return addressee when
going between agents.
=cut
my @postback :Field
:All('postback')
:Type('ARRAY' );
=item input
The exact, unparsed input string from the user. This might be useful for
some commands, but mostly is ignored. If not provided it should be automatically
generated from the command and args if necessary.
=cut
my @input :Field
lib/Agent/TCLI/Request.pm view on Meta::CPAN
B<pop_>field<> - works the same as I<pop>, returing the popped member.
B<push_>field<(list)> - works the same as I<push>.
B<depth_>field<> - returns the curent size of the array.
=item Auto-Attributes
Agent::TCLI::Request has an AutoMethod routine that can create object attributes
on the fly. These all use lower case set_/get_ mutators which differentiates
them from the pre-defined attributes. Since all responses should contain the
original Request object, this is a handy way to pass stateful information
about the Request to the postback handling the response.
For example: $request->set_test('like');
If the new attribute name contains 'array', it is created as an array type
and the array mutators listed above will apply.
=back
=cut
lib/Agent/TCLI/Request.pm view on Meta::CPAN
my ($self, $txt, $code) = @_;
# TODO better validation of code
$code = 200 unless defined($code);
my $response = Agent::TCLI::Response->new(
'body' => $txt,
'code' => $code,
'id' => $self->id,
'sender' => [@{$self->sender}],
'postback' => [@{$self->postback}],
'response_count'=>$self->response_count,
);
if ( $self->response_verbose )
{
$response->args($self->args);
$response->input($self->input);
$response->command($self->command);
$response->response_verbose($self->response_verbose);
lib/Agent/TCLI/Request.pm view on Meta::CPAN
my $response;
if ( ref($txt) =~ /Response/ )
{
$response = $txt;
}
else
{
$response = $self->MakeResponse( $txt, $code);
}
# If we have a control, then we really need to post to it's id.
# I could stringify control to avoid this, but that seems rather inobvious
# and I'd probably create some bug somewhere else that would be horrific
# to debug because of it.
# TODO. Can't do multple replies like this.
my $sender = $self->sender->[0];
my $postback = $self->postback->[0];
if ( ref($sender) =~ /Control/ )
{
$self->Verbose("Respond: control(".$sender->id.") pb(".$postback.
") txt($txt)",2);
$sender = $sender->id()
}
else
{
$self->Verbose("Respond: sender(".$sender.") pb(".$postback.
") txt($txt)",2);
}
$self->Verbose("Respond: id(".$id[$$self].") count(".$response_count[$$self].
") code(".$response->code.")",1) if defined($id[$$self]);
$self->Verbose("Respond: sender(".$sender.") pb(".$postback.")");
$kernel->call( $sender => $postback => $response );
}
# Standard class utils are inherited
1;
#__END__
=back
=head3 INHERITED METHODS
lib/Agent/TCLI/Transport/Base.pm view on Meta::CPAN
@_[KERNEL, OBJECT, SESSION];
# TODO, do some proper signal handling
# especially reconnect on HUP and something on INT
$self->Verbose('_shutdown: dropping controls',1, $self->controls);
if ( defined( $self->controls ) )
{
foreach my $control ( values %{$self->controls} )
{
$kernel->post( $control->id() => '_shutdown' );
delete( $self->controls->{ $control->id } );
}
}
$self->Verbose("_shutdown: removing alarms",1,$kernel->alarm_remove_all() );
$kernel->alias_remove( $self->alias );
return("_shutdown ".$self->alias );
}
sub ControlExecute {
my ($kernel, $self, $control, $request ) =
@_[KERNEL, OBJECT, ARG0, ARG1 ];
$self->Verbose("ControlExecute: control(".$control->id.") req(".$request->id.") ");
# 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 );
}
}
=item PackRequest
This object method is used by transports to prepare a request for transmssion.
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
# 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.")");
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
# 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.")");
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
=cut
sub _init :Init {
my ($self, $args) = @_;
$self->set(\@default_request, Agent::TCLI::Request->new({
'id' => 1,
# 'args' => ,
# 'command' => ,
'sender' => [$self->alias],
'postback' => ['PostResponse'],
'input' => '',
'response_verbose' => 1, # Must be set to get test back with response
'verbose' => $self->verbose,
'do_verbose' => $self->do_verbose,
})) unless defined( $self->default_request );
$self->control_options->{'local_address'} = '127.0.0.1'
unless defined($self->control_options->{'local_address'});
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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 );
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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.
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
$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);
# We did something, clear out counter.
$dispatch_counter[$$self] = 0;
}
elsif ( $dispatch_counter[$$self] >= $dispatch_retries[$$self] &&
( $next_request = $self->shift_requests ) )
{
$self->Verbose($self->alias.":Dispatch: STALLED sending request id(".
$next_request->id.") overriding post_it" ,1,);
$kernel->yield( 'SendRequest', $next_request );
$requests_sent[$$self]++;
# But wait, are there more?
$kernel->delay('Dispatch', $delay, $delay);
# We did something, clear out counter.
$dispatch_counter[$$self] = 0;
}
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
sub SendRequest {
my ($kernel, $self, $sender, $request) =
@_[KERNEL, OBJECT, SENDER, ARG0 ];
$self->Verbose($self->alias.":SendRequest: sender(".$sender->ID.") request(".$request->id.") \n");
$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.
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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.
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
=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.
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
xpath => {
'Version' => { 'path' => 'version/text()' },
'Yaml' => { 'path' => 'yaml/text()' },
'Request' => { 'type' => 'master'},
}
);
# $self->Verbose("_start: Setting General XMPP Callbacks" , 2 );
# $xmpp->SetCallBacks(
# 'send' => $session->postback('VerboseCallBack'),
# 'receive' => $session->postback('VerboseCallBack'),
# 'presence' => $session->postback('recv_presence'),
# 'iq' => $session->postback('recv_iq'),
# );
$self->Verbose("_start: Setting XMPP Message Callbacks" , 2 );
$xmpp->SetMessageCallBacks(
'normal' => $session->postback('recvmsg'),
'chat' => $session->postback('recvmsg'),
'groupchat' => $session->postback('recvmsgGroupchat'),
'headline' => $session->postback('recvmsgHeadline'),
'error' => $session->postback('recvmsgError'),
);
# $xmpp->SetPresenceCallBacks(
# available => $session->postback('recv_pres'),
# unavailable => $session->postback('recv_pres'),
# );
$xmpp->SetIQCallBacks(
'tcli:request' => {
'get' => $session->postback('recv_iqRequest'),
# 'set' => function,
'result'=> $session->postback('recv_iqResponse'),
},
);
$self->set(\@xmpp, $xmpp);
$kernel->yield('Login') if (defined( $self->jpassword ));
return ($self->alias."_start whohoo");
} # End sub start
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
# This is to keep from reconnectiing when XMPP responds that it is disconnected.
$self->connection_retries(0);
if ( defined($self->control_options)
&& exists( $self->control_options->{'packages'} ))
{
# Shut down any packages.
foreach my $package ( @{$self->control_options->{'packages'} })
{
$kernel->post( $package->name => '_shutdown' );
}
}
if ( $xmpp[$$self]->Connected )
{
$xmpp[$$self]->Disconnect;
$self->Verbose("_shutdown: Disconnecting ");
}
# define xmpp
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
sub GetRequestForNode {
my ($self, $node ) = @_;
# This is used to package up a simple request easily
my $input = $node->GetBody;
$self->Verbose("GetRequestForNode: input($input)\n",2);
my $request = Agent::TCLI::Request->new({
'sender' => $self->alias,
'postback' => 'PostResponse',
'input' => $input,
'response_verbose' => 1,
'verbose' => $self->verbose,
'do_verbose' => $self->do_verbose,
});
$request->set_recv($node);
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
my $control = $self->GetControlForNode( $msg );
return unless $control;
my $request = $self->GetRequestForNode($msg);
# The control is transport agnostic. All it needs to know
# is the input and what is stored in the control and request.
$self->Verbose("recvmsg: sending to contol \n",2);
$kernel->post( $control->id() => 'Execute' => $request );
}
sub recvmsgGroupchat {
my ($kernel, $self, $jSessionID, $packet) =
@_[KERNEL, OBJECT, ARG0, ARG1 ];
my $msg = $packet->[1];
$self->Verbose("recvmsgGroupchat: msg dump",3,$msg);
if ( $msg->GetFrom eq $jid[$$self] )
{
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
# else
# {
# $self->Verbose("but it's to the group and not for $me \n");
# return;
# }
my $request = $self->GetRequestForNode($msg);
$self->Verbose("recvmsgGroupChat: sending to contol \n",2);
$kernel->post( $control->id() => 'Execute' => $request );
}
sub recvmsgHeadline {
my ($kernel, $self, $jSessionID, $response) =
@_[KERNEL, OBJECT, ARG0, ARG1 ];
my $msg = $response->[1];
return unless $self->authorized(
$msg->GetFrom('jid'),
);
my $input = $msg->GetBody;
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
my $packed_request = $msg->GetQuery->GetYaml;
# $self->Verbose("recv_iqRequest: msg",4,$msg);
# $self->Verbose("recv_iqRequest: GetRequest",3,$msg->GetQuery->GetRequest);
# Unpack the request..
my $request = $self->UnpackRequest($packed_request);
# Need to put us on the bottom of the stack so we can return response
$request->unshift_sender($self->alias);
$request->unshift_postback('PostResponse');
my $control = $self->GetControlForNode( $msg );
return unless $control;
$self->Verbose("recv_iqRequest: sending to contol(".$control->id().") \n",1);
$self->Verbose("recv_iqRequest: control dump.... \n".$control->dump(1), 5 );
# 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 );
}
}
sub recv_iqResponse {
my ($kernel, $self, $jSessionID, $packet) =
@_[KERNEL, OBJECT, ARG0, ARG1 ];
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
# $self->Verbose("recv_iqResponse: XMLNS",1,$msg->GetQueryXMLNS);
# $self->Verbose("recv_iqResponse: GetQuery",1,$msg->GetQuery);
# $self->Verbose("recv_iqResponse: GetYaml",1,$msg->GetQuery->GetYaml);
# $self->Verbose("recv_iqResponse: GetRequest",1,\$msg->GetQuery->GetRequest);
# Unpack the response..
my $response = $self->UnpackResponse($packed_response);
# The bottom of the stack should be where to go.
my $sender = $response->shift_sender;
my $postback = $response->shift_postback;
$self->Verbose("recv_iqResponse: posting to ".
$sender." => ".$postback." => ".$response->id);
$kernel->call( $sender => $postback => $response );
}
sub PostRequest {
my ($kernel, $self, $sender, $request, ) =
@_[KERNEL, OBJECT, SENDER, ARG0, ];
$self->Verbose("PostRequest: sender(".$sender->ID.")
request(".$request->id.") \n");
my $addressee;
# First, check if we're on the bottom of the stack.
if ( $request->sender->[0] eq $self->alias )
{
#we're here, take us off
$request->shift_sender;
$request->shift_postback;
}
# elsif ( defined($request->sender->[0]) ) # implied != $self->alias
# {
# # TODO Genereate real error
# $self->Verbose("PostRequest: Whoops! Got something in sender0 that shouldn't be there \n ".$request->dump(1));
# return;
# }
if ( $request->sender->[0] eq 'XMPP' )
{
#take off XMPP and adressee.
$request->shift_sender;
$addressee = $request->shift_postback;
}
elsif ( defined($request->sender->[0]) ) # implied != 'XMPP'
{
# TODO Genereate real error
$self->Verbose("PostRequest: Whoops! Got something in sender0 that shouldn't be there \n ".$request->dump(1));
return;
}
# make sure sender put themselves on stack.
# need to resolve POE sender to alias to do this.
# if ( !defined($request->sender->[0]) || $request->sender->[0] ne $sender )
# {
# # Do them a favor and put them on.
# $request->unshift_sender( $sender );
# # but we'll have to assume they are at least compliant with response returns.
# $request->unshift_postback('PostResponse');
# $self->Verbose($self->alias.":PostRequest: putting ".$sender." on sender/postback stack");
# }
# Transmit will take care of putting self onto stack.
# Now Transmit it
$kernel->call($self->alias, 'TransmitRequest', $request, $addressee );
return;
}
sub PostResponse {
my ($kernel, $self, $sender, $response, $control) =
@_[KERNEL, OBJECT, SENDER, ARG0, ARG1];
$self->Verbose("PostResponse: sender(".$sender->ID.")
Code(".$response->code.") \n");
# my $request = $response->request;
# The response should come back with either message nodes attached
# or something in the sender/postback stack to provide
# directions on where to go. If there a XMPP in the sender/postback
# that means the request should get transmitted as a whole request (iq),
# and not as a message/body, so let Transmit handle that.
# First, check if we're on the bottom of the stack.
if ( defined($response->sender->[0]) && $response->sender->[0] eq $self->alias )
{
#we're here, but we don't take us off anymore, so there is not much to do.
}
elsif ( defined($response->sender->[0]) ) # implied != $self->alias
{
# TODO Genereate real error
$self->Verbose("PostResponse: Whoops! Got something in sender0 that shouldn't be there \n ".$response->dump(1));
return;
}
# Now if there's anything for XMPP on the stack, Transmit it
if ( defined($response->sender->[1]) && $response->sender->[1] eq 'XMPP' )
{
#we're here, take us off bottom
$response->shift_sender;
$response->shift_postback;
$kernel->yield('TransmitResponse', $response );
return;
}
elsif ( defined($response->sender->[1]) ) # implied != 'XMPP'
{
# TODO Genereate real error
$self->Verbose("PostResponse: Whoops! Got something in sender1 that shouldn't be there \n ".$response->dump(1));
return;
}
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
}
}
elsif ( defined($control) )
{
$msg = Net::XMPP::Message->new();
$msg->SetTo( $control->get_jid() );
$msg->SetFrom ( $jid[$$self] );
}
else
{
$self->Verbose("PostResponse: Can't post, nowhere to go");
return;
}
}
$msg->SetBody( $response->body );
$self->Verbose("PostResponse: Sending to xmpp", 2);
$self->Verbose("PostResponse: msg dump ", 5, $msg);
# Put $msg in request for next time.
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
}
sub TransmitRequest {
my ($kernel, $self, $sender, $request, $addressee ) =
@_[KERNEL, OBJECT, SENDER, ARG0, ARG1 ];
$self->Verbose($self->alias.":TransmitRequest: id(".
$request->id.") \n");
# Put us on bottom so we get the response back
$request->unshift_sender('XMPP');
$request->unshift_postback($self->jid->GetJID('full') );
# Prepare the request..
my $packed_request = $self->PackRequest($request);
# Create new msg
my $msg = Net::XMPP::IQ->new();
# addressee must have resource, default to /tcli if not provided
$addressee .= '/tcli' unless ($addressee =~ qr(/) );
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
$response->id.") \n");
# my $request = $response->request;
my $addressee;
# First, check if we're on the bottom of the stack.
if ( $response->sender->[0] eq 'XMPP' )
{
#we're here, take us off
$response->shift_sender;
$addressee = $response->shift_postback;
}
elsif ( defined($response->sender->[0]) ) # implied != 'XMPP'
{
# TODO Genereate real error
$self->Verbose("TransmitResponse: Whoops! Got something in sender that shouldn't be there ".$response->dump(1));
return;
}
else
{
# TODO Genereate real error
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
{
$self->Verbose("send_message: Creating new reply XMPP::Message", 2);
# If we've got a recieved message, use it
$rmsg = $msg->Reply();
if ( $msg->GetType eq 'groupchat' )
{
$self->Verbose("send_response: Reply dump ", 2, $rmsg);
$rmsg->SetTo( $msg->GetFrom('jid')->GetJID('base') );
$rmsg->SetFrom( $jid[$$self] );
$self->Verbose("send_response: Reply post dump ", 2, $rmsg);
}
}
$msg->SetBody( $message );
$self->Verbose("send_message: Sending to xmpp", 2);
# $control->send($rmsg);
$self->xmpp->Send($rmsg);
} # end sub xmpp_send_msg
t/TCLI.Command.GetoptLucid.t view on Meta::CPAN
# TASK Test suite is not complete. Need testing for catching errors.
BEGIN {
use_ok('Agent::TCLI::Command');
}
my $request = Agent::TCLI::Request->new({
'id' => 1,
'args' => ['paramint', '7', 'verbose', ],
'command' => ['testing', ],
'sender' => 'Control',
'postback' => 'TestResponse',
'input' => 'testing paramint 7 verbose',
});
my $verbose = Agent::TCLI::Parameter->new(
constraints => ['UINT'],
help => "an integer for verbosity",
manual => 'This debugging parameter can be used to adjust the verbose setting for the XMPP transport.',
name => 'test_verbose',
aliases => 'verbose|v',
t/TCLI.Request.t view on Meta::CPAN
use_ok('Agent::TCLI::Request');
use warnings;
use strict;
use POE;
my $test1 = Agent::TCLI::Request->new({
'id' => 1,
'args' => ['one', 'two', 'three', ],
'command' => ['testing', ],
'sender' => 'Control',
'postback' => 'TestResponse',
'input' => 'testing one two three',
});
is(ref($test1),'Agent::TCLI::Request','new test1 object with args');
my $test2 = Agent::TCLI::Request->new();
is(ref($test2),'Agent::TCLI::Request', 'new test2 object no args' );
# Test id get-set methods
t/TCLI.Request.t view on Meta::CPAN
ok($test2->id(2),'$test2->id set ');
is($test2->id,2, '$test2->id get from set');
# Test sender accessor/mutator methods
is($test1->sender->[0],'Control', '$test1->sender from init args');
# for init 'sender' => 'Control',
ok($test2->sender(['transport_xmpp','transport_test']),'$test2->sender init mutator');
is_deeply($test2->sender,['transport_xmpp','transport_test'], '$test2->sender accessor');
# Test postback accessor/mutator methods
is($test1->postback->[0],'TestResponse', '$test1->postback from init args');
# for init 'postback' => 'TestResponse',
ok($test2->postback(['test@example.com/test','test-master']),'$test2->postback init mutator');
is_deeply($test2->postback,['test@example.com/test','test-master'], '$test2->postback accessor');
# Test args get-set methods
is_deeply($test1->args,['one', 'two', 'three', ], '$test1->get_args get from init args');
ok($test2->args(['one'] ),'$test2->set_args set ');
is_deeply($test2->args,['one'] , '$test2->get_args from set');
# test automethods for args array
is($test1->shift_args,'one', '$test1->shift_args ');
is_deeply($test1->args,[ 'two', 'three', ], '$test1->args after shift');
t/TCLI.Request.t view on Meta::CPAN
ok($test1->unshift_myarray('one'), '$test1->unshift_myarray ');
is_deeply($test1->get_myarray,['one', 'two', 'three', 'four', ], '$test1->get_myarray');
is($test1->depth_myarray,4, '$test1->depth_myarray ');
#MakeResponse
my $resp2 = $test2->MakeResponse("test", 200);
is_deeply($resp2->sender,['transport_xmpp','transport_test'], '$resp2->sender accessor');
is_deeply($resp2->postback,['test@example.com/test','test-master'], '$resp2->postback accessor');
is($resp2->shift_sender,'transport_xmpp','shift sender');
is($resp2->shift_postback,'test@example.com/test','shift postback');
# Did the original arrays not change.
is_deeply($test2->sender,['transport_xmpp','transport_test'], '$test2->sender accessor');
is_deeply($test2->postback,['test@example.com/test','test-master'], '$test2->postback accessor');
( run in 0.911 second using v1.01-cache-2.11-cpan-5735350b133 )