Agent-TCLI
view release on metacpan or search on metacpan
Revision history for Agent-TCLI
0.032 Thu May 3 13:51:13 EST 2007
- Bug fixes to support inter Agent communications during tests
- Fixes to support Testee get_param and get_responses
- Changed Control to load commands from XML for easier maintenance
- Added defaul commands for Control manipulation
0.031 Mon Apr 30 07:53:27 EST 2007
- Corrected version decimal place error in Transport directory too!
0.030 Mon Apr 30 07:22:52 EST 2007
- Corrected version decimal place error.
0.003 Mon Apr 30 01:49:10 EST 2007
- Added working Agent script to bin
- Fixed up the POD docs a bunch.
- Added more support for running external commands
- Removed some cruft
- Fixed lots of little bugs
- Moved Testee, which breaks tests in dependent distributions
- Cleaned up version numbers and Id fields
- Removed dependency on PoCo::SimpleLog for Package::Tail
lib/Agent/TCLI/Base.pm view on Meta::CPAN
=over
=cut
# Standard class utils
# I need to redo err handling as its not useful as is.
=item err
Error message if something went wrong with a method call. Cannot be set or
passed in with new. Not actually used, as erroring needs to be revisited.
=cut
my @err :Field
:Get('err');
=item verbose
Turns on/off internal state messages and warnings. Higher values produce more
verbosity.
lib/Agent/TCLI/Command.pm view on Meta::CPAN
:Type('HASH')
:Arg('name'=>'required', 'default'=> { } )
:Acc('required');
=item cl_options
These are command line options that will be issued every time the
command is called. They will begin the value returned by
BuildCommandLine. Make sure that they are not available as
parameters for this command. There is no checking for
duplicates and that will likely cause errors.
B<cl_options> should only contain scalar values.
=cut
my @cl_options :Field
# :Type('scalar')
:All('cl_options');
# Standard class utils are inherited
=back
lib/Agent/TCLI/Command.pm view on Meta::CPAN
# $cmdhash{'handler'} = $handler[$$self] if (defined($handler[$$self]));
# $cmdhash{'start'} = $start[$$self] if (defined($start[$$self]));
# $cmdhash{'stop'} = $stop[$$self] if (defined($stop[$$self]));
#
# return ( \%cmdhash );
#}
=item GetoptLucid( $kernel, $request)
Returns an option hash keyed on parameter after the arguments have bee parsed
by Getopt::Lucid. Will respond itself if there is an error and return nothing.
Takes the POE Kernel and the request as args.
=cut
sub GetoptLucid {
my ($self, $kernel, $request, $package) = @_;
my (@options, $func);
lib/Agent/TCLI/Command.pm view on Meta::CPAN
# $self->Verbose("GetoptLucid: request args",1,$request->args );
# Parse the args using parameters.
eval {$opt = Getopt::Lucid->getopt(
\@options,
$request->args,
);
};
# If it went bad, error and return nothing.
if( $@ )
{
$self->Verbose('GetoptLucid: got ('.$@.') ');
$request->Respond($kernel, "Invalid Args: $@ !", 400);
return (0);
}
return( $opt );
}
=item Validate( <kernel>, <request>, <package> )
Returns a hash keyed on parameter after the arguments have been parsed
by Getopt::Lucid and validated by FormValidator::Simple as per the constraints
specified in the Parameter or Command definitions.
Will respond itself if there is an error and return nothing.
Takes the POE Kernel, the Request, and the Package as args.
=cut
sub Validate {
my ($self, $kernel, $request, $package) = @_;
# Getopt will send error if problem.
return unless (my $opt = $self->GetoptLucid($kernel, $request, $package) );
# my %args = $opt->options;
my %args = $self->ApplyDefaults($opt, $package, $request->input );
# $self->Verbose("Validate: param",1,\%args);
# $self->Verbose('Validate: $request->input ',1,$request->input);
# are there any left?
if (keys %args == 0 )
lib/Agent/TCLI/Command.pm view on Meta::CPAN
if (!ref( $args{ $check->name } ) );
}
}
$self->Verbose("Validate: profile ",2,\@profile);
# $self->Verbose("Validate: input",1,\%input);
my $results = FormValidator::Simple->check( \%input => \@profile);
if ( $results->has_error ) {
foreach my $key ( @{ $results->error() } ) {
foreach my $type ( @{ $results->error($key) } ) {
$txt .= "Invalid: $key not $type \n";
$txt .= "$key: ".$input{$key}." \n";
}
}
$self->Verbose('Validate: failed ('.$txt.') ');
$request->Respond($kernel,$txt, 400);
return (0);
}
# create class objects if necessary
lib/Agent/TCLI/Command.pm view on Meta::CPAN
if (defined( $param->class ) &&
$param->class =~ /::/ )
{
my $class = $param->class;
$self->Verbose("Validate: class($class) attr($attr) args{$attr}=>".$args{$attr},2);
my $obj;
eval {
no strict 'refs';
$obj = $class->new($args{$attr});
};
# If it went bad, error and return nothing.
if( $@ )
{
$@ =~ qr(Usage:\s(.*)$)m ;
$txt = $1;
$self->Verbose('Validate: new '.$class.' got ('.$txt.') ');
$request->Respond($kernel, "Invalid: $attr !", 400);
return;
}
$args{$attr} = $obj;
}
lib/Agent/TCLI/Command.pm view on Meta::CPAN
}
return( %opt );
}
=item BuildCommandLine( <param_hash>, <with_cmd> )
Returns a hash keyed on parameter after the arguments have been parsed
by Getopt::Lucid and validated by FormValidator::Simple as per the constraints
specified in the Parameter or Command definitions.
Will respond itself if there is an error and return nothing.
Takes the POE Kernel, the Request, and the Package as args.
=cut
sub BuildCommandLine {
my ($self, $param_hash, $with_cmd ) = @_;
my $command_line = $with_cmd ? $self->command." " : '';
lib/Agent/TCLI/Control.pm view on Meta::CPAN
sub RegisterContexts {
my ($self, $cmd ) = @_;
$self->Verbose( "RegisterContext: (".$cmd->name.") ");
# TODO Error catching
# Loop over each context key to add command to list
foreach my $c1 ( keys %{ $cmd->contexts } )
{
my $v1 = $cmd->contexts->{$c1};
# Not warning on error if 'ROOT' and hash
if ( ( $c1 ne 'ROOT' ) && ( ref( $v1 ) =~ /HASH/ ) )
{
foreach my $c2 ( keys %{ $v1 } )
{
my $v2 = $v1->{$c2};
if ( ref( $v2 ) =~ /HASH/ )
{
foreach my $c3 ( keys %{ $v2 } )
{
my $v3 = $v2->{$c3};
lib/Agent/TCLI/Control.pm view on Meta::CPAN
$self->Verbose("_start:\trunning ".$startcmd->{'name'}." 's start \n",2) ;
eval { $startcmd->{'start'}( kernel => $kernel,
object => $self,
session => $session,
) }
}
}
elsif ( ref($startcmd) =~ /Agent::TCLI::Command/ )
{
$self->Verbose("_start:\trunning ".$startcmd->name()." 's start \n",2) ;
# TODO some error checking here maybe :)
$startcmd->start( { kernel => $kernel,
object => $self,
session => $session,
} );
}
}
# Handlers are events to send the request to. The result will be returned
# to AsYouWished.
lib/Agent/TCLI/Control.pm view on Meta::CPAN
}
($cmds, , ) = $self->ListCommands(['UNIVERSAL']);
if ( $code == 200 )
{
$txt .= "\nThe following global commands are available. \n";
foreach $cmd ( sort keys %{$cmds} )
{
$txt .= " ".$cmd." " unless ($cmds->{$cmd}->topic =~ /debug|admin/);
}
}
# Otherwise txt has error from first ListCommands
$request->Respond($kernel, $txt, $code );
return;
}
# Just the globals please
elsif( $request->args->[0] =~ /global/i )
{
($cmds, $txt, $code ) = $self->ListCommands(['UNIVERSAL']);
if ( $code == 200 )
{
$txt .= "\nThe following global commands are available. \n";
foreach $cmd ( sort keys %{$cmds} )
{
$txt .= "\t".$cmd." - ".$cmds->{$cmd}->help." \n";
}
}
# Otherwise txt has error from first ListCommands
$request->Respond($kernel, $txt, $code );
return;
}
# perhaps we want to ignore the current context
elsif ( $request->args->[0] eq '/' )
{
@help = @{$request->args};
}
# finally, just help
elsif ( $request->depth_args >= 1 )
lib/Agent/TCLI/Control.pm view on Meta::CPAN
$txt .= "\t".$cmd->parameters->{ $parameter }->name." - ";
$txt .= $cmd->parameters->{ $parameter }->help;
}
}
}
elsif (defined($cmd) )
{
$txt = "Darn! The lazy programmer didn't supply a manual or help!"
}
# Otherwise txt has error from FindCommand
$request->Respond($kernel, $txt, $code );
} #end sub help
=item manual
A POE event to execute the manual command. Takes a request object as an ARG0.
Responds with the properl formatted manual output.
=cut
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# Need to eliminate aliases by checking something.....
$txt .= "\t".$subcmd." - ".$subcmds->{$subcmd}->help." \n"
if ($subcmds->{$subcmd}->name =~ /$cmd/ ||
$subcmds->{$subcmd}->topic !~ /general/
);
}
}
}
# Otherwise txt has error from FindCommand
# }
# elsif ( $request->depth_args == 1 )
# {
# my $on = $request->args->[0];
# my @manual = ( '/', @{$self->context}, $on );
# ($cmd, $context, $txt, $code) = $self->FindCommand(\@manual);
#
# if (defined($cmd) && defined($cmd->manual) )
# {
# $txt = "Manual for command '".$on."' \n";
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# $txt .= $cmd->parameters->{ $parameter }->help;
# }
# }
#
# }
# elsif (defined($cmd) )
# {
# $txt = "Darn! The lazy programmer didn't supply a manual or help!"
# }
#
# # Otherwise txt has error from FindCommand
# }
$request->Respond($kernel, $txt, $code );
} #end sub manual
=item exit
A POE event to handle context shift commands exit and /.
It expects a request object parameter.
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# $var = $self->$attr;
# $txt .= Dump($var)."\n";
# $code = 200;
# }
# }
# elsif ( $self->can( $attr ) )
# {
# $txt = $what.": #!undefined";
# $code = 200;
# }
# else # should get here, but might if parameter error.
# {
# $txt = $what.": #!ERROR does not exist";
# $code = 404;
# }
# }
# }
#
# # if we didn't find anything at all, then a 404 is returned
# if (!defined($txt) || $txt eq '' )
# {
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# exists( $meth->{$attr}{'type'} ) &&
# $meth->{$attr}{'type'} =~ /::/ )
# {
# my $class = $meth->{$attr}{'type'};
# $self->Verbose("set: class($class) param($param) attr($attr) ");
# my $obj;
# eval {
# no strict 'refs';
# $obj = $class->new($param->{$attr});
# };
# # If it went bad, error and return nothing.
# if( $@ )
# {
# $@ =~ qr(Usage:\s(.*)$)m ;
# $txt = $1;
# $self->Verbose('set: new '.$class.' got ('.$txt.') ');
# $request->Respond($kernel, "Invalid: $attr !", 400);
# return;
# }
# eval { $self->$attr($obj) };
# if( $@ )
lib/Agent/TCLI/Control.pm view on Meta::CPAN
sub push_context # :Restricted How can I test with Restricted or Private?
{
my ($self, $context) = @_;
if ( $self->print_context eq 'ROOT' && $context ne '/' )
{
$self->context( [$context] );
return (1);
}
elsif ( $context eq '/' )
{
# TODO create error instead of overwrite existing context.
$self->context( ['ROOT'] );
# Root is a null context
return (0);
}
else
{
return( push( @{$context[$$self]} , $context ) );
}
}
lib/Agent/TCLI/Package/Base.pm view on Meta::CPAN
$self->Verbose("_stop: ".$self->name." stopping");
return($self->name.":_stop complete ");
}
#Just a placeholder that does nothing but collect unhandled child events
#to keep them out of default.
sub _child {
my ($kernel, $self, $session, $id, $error) =
@_[KERNEL, OBJECT, SESSION, ARG1, ARG2 ];
$self->Verbose("child: pid($id) ");
}
=item establish_context
This POE event handler is the primary way to set context with a command.
Just about any command that has subcommands will use this method as it's handler.
An exception would be a command that sets an single handler to process all
lib/Agent/TCLI/Package/Base.pm view on Meta::CPAN
$var = $self->$attr;
$txt .= Dump($var)."\n";
$code = 200;
}
}
elsif ( $self->can( $attr ) )
{
$txt = $what.": #!undefined";
$code = 200;
}
else # should get here, but might if parameter error.
{
$txt = $what.": #!ERROR does not exist";
$code = 404;
}
}
}
# if we didn't find anything at all, then a 404 is returned
if (!defined($txt) || $txt eq '' )
{
lib/Agent/TCLI/Package/Base.pm view on Meta::CPAN
exists( $meth->{$attr}{'type'} ) &&
$meth->{$attr}{'type'} =~ /::/ )
{
my $class = $meth->{$attr}{'type'};
$self->Verbose("set: class($class) param($param) attr($attr) ");
my $obj;
eval {
no strict 'refs';
$obj = $class->new($param->{$attr});
};
# If it went bad, error and return nothing.
if( $@ )
{
$@ =~ qr(Usage:\s(.*)$)m ;
$txt = $1;
$self->Verbose('set: new '.$class.' got ('.$txt.') ');
$request->Respond($kernel, "Invalid: $attr !", 400);
return;
}
eval { $self->$attr($obj) };
if( $@ )
lib/Agent/TCLI/Package/Base.pm view on Meta::CPAN
$wheels[$$self]->{$wheel->ID}{$key} = $value;
}
else
{
$wheels[$$self]->{$wheel}{$key} = $value;
}
return 1;
}
# Input validation methods. Returns false or error message.
# These are all deprecated. Use Contraints and Command->Validator instead.
sub NotPosInt {
my ($self,$value,$name,$set) = @_;
$name = "Parameter" unless defined($name);
return ('') unless (defined ($value) && $value ne '');
return($name." is not a number: got '$value' \n") unless (Scalar::Util::looks_like_number($value) );
return($name." is not an integer: got '$value' \n") unless(int($value) == $value);
return($name." is not positive: got '$value' \n") unless ( $value >= 0);
if (defined($set))
lib/Agent/TCLI/Package/Base.pm view on Meta::CPAN
{
my $res = $self->NotWithin($value,$item);
return (0) unless $res;
$txt .= $res unless $res == 1;
}
# No item matched
return (1) unless $txt;
return ($txt);
}
# todo trap min/max non numeric errors below.
my ($min, $max, $more);
# using a range divider of : allows negative numbers in ranges
if ($range =~ /:/)
{
($min, $max, $more) = split /:/,$range;
}
else
{
($min, $max, $more) = split /-/,$range;
lib/Agent/TCLI/Package/Base.pm view on Meta::CPAN
$self->Verbose("ARG1 dumped",1,$_[ARG1]) if defined($_[ARG1]);
$self->Verbose("ARG2 dumped",1,$_[ARG2]) if defined($_[ARG2]);
return (0);
}
sub LoadYaml {
my ($self, $yaml) = @_;
$self->Verbose("LoadYaml: Loading" );
# hmmm, should trap for errors someday.
my @loadees = Load($yaml);
$self->Verbose("LoadYaml: Loadees dump",3,\@loadees );
# We can only handle an array of loadees.
foreach my $loadee ( @loadees )
{
if ( ref($loadee) ne 'HASH' )
{
$self->Verbose("LoadYaml: Bad yaml, not a hash",0);
lib/Agent/TCLI/Package/Base.pm view on Meta::CPAN
sub LoadXMLFile {
my ($self, $xml_file) = @_;
$self->Verbose("LoadXmlFile: Loading" );
my $class = ref($self) || $self;
$xml_file = File::ShareDir::module_file($class,'config.xml')
unless defined($xml_file);
# hmmm, should trap for errors someday.
my $loadees = XMLin($xml_file,
KeyAttr => [],
SearchPath => \@INC,
);
$self->Verbose("LoadYaml: Loadees dump",3,\$loadees );
# We can only handle an array of loadees.
foreach my $loadee ( @{$loadees->{'Parameter'} } )
{
lib/Agent/TCLI/Package/Tail.pm view on Meta::CPAN
elsif ( defined($params->{'seek'}) && $params->{'seek'} ne '' )
{
$seek{'Seek'} = $params->{'seek'}
}
my $wheel = POE::Wheel::FollowTail->new(
Filename => $params->{'file'}, # File to tail
Filter => $filter, # How to parse it
PollInterval => $interval, # How often to check it
InputEvent => 'Append', # Event to emit upon input
ErrorEvent => 'RunError', # Event to emit upon error
ResetEvent => 'FileReset', # Event to emit on file reset
%seek, # Can't have both seek & seekback
);
# TODO error checking
$self->Verbose('File ('.$params->{'file'}.') being watched by wheel ID('.$wheel->ID.') ' );
$self->SetWheel($wheel);
$self->SetWheelKey($wheel, 'source' => $params->{'file'} );
$files[$$self]{ $params->{'file'} } = { 'wheel' => $wheel->ID };
return (1);
}
lib/Agent/TCLI/Package/UnixBase.pm view on Meta::CPAN
=head1 SYNOPSIS
use Object::InsideOut qw(Agent::TCLI::Package::UnixBase);
=head1 DESCRIPTION
Base class for Packages needing to run other Unix programs. It provides methods
to asnychronously call Unix programs using POW::Wheel::Run through
POE::Component::Child. This base class comes with simple
event handlers to accept the output and/or errors returned from the wheel.
Typically, one may want their subclass to replace the stdout method
with one that does more processing of the responses. One should use the
methods here as a starting point in such cases.
Commands run through these methods are run in their own processes asychonously.
Other Agent processing continues while the results of the commands are
captured and returned. Package authors need to ensure that their command
threads shut down or else they may exhaust system resources.
lib/Agent/TCLI/Package/UnixBase.pm view on Meta::CPAN
@_[KERNEL, OBJECT, ARG0, ARG1];
$self->Verbose("stderr: wheel_id(".$resp->{'wheel'}.") ",1);
my $request = $self->GetWheelKey( $resp->{'wheel'}, 'request' );
my $output = "STDERR: ".$resp->{'out'}." !!! ";
$request->Respond( $kernel, $output, 400);
}
=item error
This POE event handler is the default way errors are returned from
the child command being run.
=cut
sub error {
my ($kernel, $self, $operation, $errnum, $errstr, $wheel_id) =
@_[KERNEL, OBJECT, ARG0, ARG1, ARG2, ARG3];
$errstr = "remote end closed" if $operation eq "read" and !$errnum;
my $output = "Wheel $wheel_id generated $operation error $errnum: $errstr\n";
$self->Verbose("error: output($output)",2);
my $request = $self->GetWheelKey( $wheel_id, 'request' );
$request->Respond( $kernel, $output, 400) if defined($request);
}
=item done
This POE event handler is the default way a child indicates that it is
done.
lib/Agent/TCLI/Testee.pm view on Meta::CPAN
B<is_*> and B<like_*> tests are greedy by default. That is they use up and expect
a response for every test. Other tests (not yet available), such as
B<response_time> (coming soon) are not greedy and act on the next response
received while still allowing other tests to execute on the same response. It
might be useful to have no greedy versions of B<is_*> and B<like_*> but the
exact syntax to do so has not been worked out yet.
=head3 Response Codes
The response codes that come back in a response are modeled after HTTP Status
codes. For most cases, the ok / is_success and not_ok / is_error codes will
suffice for testing.
There are some existing packages, most notably
Agent::TCLI::Package::Tail, which have commands that may take a while to return
results after the command is accepted. These packages will return a 100
(Continue, or in SIP, Trying) to indicate that the request was received and
acted upon, but the result is not yet determined. One may explictly test for
a 100 response, but if one does not, it is silently ignored.
TCLI response codes will maintain compatibility
lib/Agent/TCLI/Testee.pm view on Meta::CPAN
sub are_successes {
my $self = shift;
# Must sneak an extra param in there so do_test will check codes correctly
$self->last_request(
$self->test_master->build_test($self, 'are_success-code',
$_[0], 1, '', $_[1])
);
return( $self->last_request);
}
=item not_ok / is_error
not_ok ( 'some request', <test_name> );
B<not_ok> makes a request of the testee and passes if the response
has a code indicating failure. B<not_ok> is really just an alias for B<is_error>
and they can be used interchangably. If the test fails, the response body
will be output with the diagnostics.
=cut
sub is_error {
my $self = shift;
# Must sneak an extra param in there so do_test will check codes correctly
$self->last_request(
$self->test_master->build_test($self, 'is_error-code',
$_[0], 1, '', $_[1])
);
return( $self->last_request);
}
*not_ok = \&is_error;
#=item do / is_trying
#
# do ( 'some request', <timeout>, <test_name> );
#
#Some commands, such as setting a tail or watch, will not return response
#with content immediately. These may however return a response with a
#seies 100 code for Trying. B<do> makes a request of the testee and passes
#if a Trying response is received within the timeout in seconds.
#B<do> is really just an alias for B<is_trying>
lib/Agent/TCLI/Testee.pm view on Meta::CPAN
# $self->last_request(
# $self->test_master->build_test($self, 'is_trying-code',
# $_[0], 1, '', $_[1])
# );
# return( $self->last_request);
#}
#
#*do = \&is_trying;
sub are_errors {
my $self = shift;
# Must sneak an extra param in there so do_test will check codes correctly
$self->last_request(
$self->test_master->build_test($self, 'are_error-code',
$_[0], 1, '', $_[1])
);
return( $self->last_request);
}
=item is_body
is_body ( 'some request', 'expected response', <test_name> );
is_body() makes a request of the testee and compares the response
lib/Agent/TCLI/Transport/Base.pm view on Meta::CPAN
$self->Verbose("stop: ".$self->name." stopping " ,1);
}
=item _child
Just a placeholder.
=cut
sub _child {
my ($kernel, $self, $session, $id, $error) =
@_[KERNEL, OBJECT, SESSION, ARG1, ARG2 ];
$self->Verbose("child: id($id) error($error)") if (defined($error));
}
=item _shutdown
Forcibly shutdown
=cut
sub _shutdown :Cumulative {
my ($kernel, $self, $session) =
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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 );
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
}
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 } },
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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) )
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
# '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'),
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
$self->Verbose("_shutdown: Disconnecting ");
}
# define xmpp
# what about Disconnected????
$self->xmpp->SetMessageCallBacks(
'normal' => undef,
'chat' => undef,
'groupchat' => undef,
'headline' => undef,
'error' => undef,
);
$self->xmpp->SetPresenceCallBacks(
available => undef,
unavailable => undef,
);
$self->xmpp->SetIQCallBacks(
'tcli:request' => {
'get' => undef,
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
resource => $self->jid()->GetResource,
);
$self->Verbose("login: Did login for ".$self->jid()->GetUserID." Got ".$login[0] );
if ( defined($login[0]) && $login[0] eq 'ok')
{
$kernel->yield('Online');
}
elsif ( defined($login[1]) )
{
$txt .= "Login error-> ".$login[1];
}
else
{
$txt .= "Bad Login error-> ".$xmpp[$$self]->GetErrorCode();
}
}
else
{
$txt .= "Connection error-> ".$xmpp[$$self]->GetErrorCode();
}
if ($txt ne '' )
{
$self->Verbose("login: ".$txt."\n",1,$xmpp[$$self]->GetErrorCode());
$kernel->delay_set('Disconnected' => 10 , 1 );
}
} # end sub login
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
$self->Verbose("recvmsgGroupchat:prefixed input($input) ");
}
else
{
$self->Verbose("recvmsgGroupchat:named-prefixed not for me ignoring");
return;
}
}
else
{
$self->Verbose("recvmsgGroupchat: mode error ignoring");
return;
}
# if ( $input =~ /$me:/i )
# {
# $input =~ s/\s*($me):\s*//;
# my $target = $1;
# $self->Verbose("recvmsgGroupchat input($input) target($target) ");
# if ( $target ne $me )
# {
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
# 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 );
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
# 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;
}
my $msg = $response->get_send();
# If the send message has not been set up, then do it.
if ( ref($msg) ne 'Net::XMPP::Message')
{
$self->Verbose("PostResponse: Creating new Send XMPP::Message", 2);
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
# 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
$self->Verbose("TransmitResponse: Got nowhere to go. ");
return;
}
# Prepare the response..
my $packed_response = $self->PackResponse($response);
# Create new msg
my $msg = Net::XMPP::IQ->new();
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
# Don't talk to oneself.......
return if ( $user->GetJID('full') eq $self->jid->GetJID('full') );
# or to self in chatroom
return if ( $user->GetResource eq $self->jid->GetUserID );
$self->Verbose("GetControlForNode: type(".$type.") user(".$user->GetJID('full').") \n");
my $control_id;
# Message Types
# Using user with resource for normal and chat. Not even sure about headline or error.
if ( $type eq 'normal' || $type eq '' )
{
$control_id = $user->GetJID('full').'-'.$type;
}
elsif ( $type eq 'chat' )
{
$control_id = $user->GetJID('full').'-'.$node->GetThread;
}
elsif ( $type eq 'groupchat' )
{
# chatroom should not use the resource
$control_id = $user->GetJID('base').'-'.$type;
}
elsif ( $type eq 'headline' )
{
$control_id = $user->GetJID('full').'-'.$type;
}
elsif ( $type eq 'error' )
{
$control_id = $user->GetJID('full').'-'.$type;
}
# IQ, treat like a normal message
elsif ( $type eq 'get' )
{
$control_id = $user->GetJID('full').'-'.$type;
}
else
t/TCLI.Command.BuildCommandLine.t view on Meta::CPAN
use strict;
use Test::More tests => 13;
use Agent::TCLI::Parameter;
#use Agent::TCLI::Request;
#use Getopt::Lucid;
#use POE;
#
#use Data::Dump qw(pp);
# TASK Test suite is not complete. Need more testing for catching errors.
BEGIN {
use_ok('Agent::TCLI::Command');
}
my $text1 = Agent::TCLI::Parameter->new(
name => 'text1',
aliases => 't1',
constraints => ['ASCII'],
help => "text for a parameter",
t/TCLI.Command.GetoptLucid.t view on Meta::CPAN
# $Id: TCLI.Command.GetoptLucid.t 57 2007-04-30 11:07:22Z hacker $
use Test::More tests => 36;
use Agent::TCLI::Parameter;
use Agent::TCLI::Request;
use Getopt::Lucid;
use POE;
use Data::Dump qw(pp);
# 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',
t/TCLI.Command.t view on Meta::CPAN
#!/usr/bin/env perl
# $Id: TCLI.Command.t 57 2007-04-30 11:07:22Z hacker $
use Test::More qw(no_plan);
use lib 'blib/lib';
use Data::Dump qw(pp);
# TASK Test suite is not complete. Need testing for catching errors.
BEGIN {
use_ok('Agent::TCLI::Command');
}
my %cmd1 = (
'name' => 'cmd1',
'contexts' => {'/' => 'cmd1'},
'help' => 'cmd1 help',
'usage' => 'cmd1 usage',
'topic' => 'test',
t/TCLI.Control.Interactive.t view on Meta::CPAN
#!/usr/bin/env perl
# $Id: TCLI.Control.Interactive.t 62 2007-05-03 15:55:17Z hacker $
use warnings;
use strict;
use Test::More tests => 49;
#use Test::More qw(no_plan);
# TASK Test suite is not complete. Need more testing for catching errors.
use Getopt::Lucid qw(:all);
sub VERBOSE () { 0 }
my ($opt, $verbose, $poe_td, $poe_te);
eval {$opt = Getopt::Lucid->getopt([
Counter("poe_debug|d"),
Counter("poe_event|e"),
t/TCLI.Control.t view on Meta::CPAN
#!/usr/bin/env perl
# $Id: TCLI.Control.t 62 2007-05-03 15:55:17Z hacker $
use warnings;
use strict;
use Test::More tests => 402;
# TASK Test suite is not complete. Need more testing for catching errors.
use Getopt::Lucid qw(:all);
sub VERBOSE () { 0 }
my ($opt, $verbose, $poe_td, $poe_te);
eval {$opt = Getopt::Lucid->getopt([
Counter("poe_debug|d"),
Counter("poe_event|e"),
t/TCLI.Package.Base.t view on Meta::CPAN
#!/usr/bin/env perl
# $Id: TCLI.Package.Base.t 57 2007-04-30 11:07:22Z hacker $
use Test::More tests => 68;
use lib 'blib/lib';
use POE;
# TASK Test suite is not complete. Need testing for catching errors.
use_ok('Agent::TCLI::Package::Base');
use_ok('Agent::TCLI::Command');
use_ok('Agent::TCLI::Parameter');
my %cmd1 = (
'name' => 'cmd1',
'contexts' => {'/' => 'cmd1'},
'help' => 'cmd1 help',
'usage' => 'cmd1 usage',
t/TCLI.Package.XMPP.t view on Meta::CPAN
sub POE::Kernel::TRACE_DEFAULT () { $poe_td }
sub POE::Kernel::TRACE_EVENTS () { $poe_te }
use Agent::TCLI::Transport::Test;
use Agent::TCLI::Testee;
use Agent::TCLI::Transport::XMPP;
use Agent::TCLI::User;
use POE;
# TASK Test suite is not complete. Need testing for catching errors.
use_ok('Agent::TCLI::Package::XMPP');
use_ok('Net::XMPP::JID');
# Set up transport, otherwise commands don't work
my @packages = (
# Agent::TCLI::Package::XMPP->new(
# 'verbose' => $verbose ,
# 'do_verbose' => sub { diag( @_ ) },
t/TCLI.Parameter.t view on Meta::CPAN
#!/usr/bin/env perl
# $Id: TCLI.Parameter.t 48 2007-04-11 12:43:07Z hacker $
use Test::More qw(no_plan);
use lib 'blib/lib';
use warnings;
use strict;
# TASK Test suite is not complete. Need more testing for catching errors.
BEGIN {
use_ok('Agent::TCLI::Parameter');
}
my $test1 = Agent::TCLI::Parameter->new(
name => 'test1',
aliases => 't1',
constraints => ['ASCII'],
help => "text for a parameter",
manual =>
t/TCLI.Request.t view on Meta::CPAN
#!/usr/bin/env perl
# $Id: TCLI.Request.t 62 2007-05-03 15:55:17Z hacker $
use Test::More tests => 48;
use lib 'blib/lib';
# TASK Test suite is not complete. Need testing for catching errors.
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', ],
t/TCLI.User.t view on Meta::CPAN
#!/usr/bin/env perl
# $Id: TCLI.User.t 40 2007-04-01 01:56:43Z hacker $
use Test::More qw(no_plan);
use lib 'blib/lib';
# TASK Test suite is not complete. Need testing for catching errors.
BEGIN {
use_ok('Agent::TCLI::User');
}
#use warnings;
#use strict;
sub user1 {
my $user1 = Agent::TCLI::User->new({
'id' => 'user1@example.com',
( run in 0.800 second using v1.01-cache-2.11-cpan-65fba6d93b7 )