Agent-TCLI
view release on metacpan or search on metacpan
requires => {
'Data::Dump' => '0',
# 'TimeDate' => '1.16',
'Date::Parse' => '1.16',
'File::ShareDir' => '0.05',
'FormValidator::Simple' => '0',
'Getopt::Lucid' => '0.16',
# 'Scalar::List::Utils' => '1.18',
'Scalar::Util' => '1.18',
'Module::Build' => '0',
'Net::Jabber' => 'undef',
'Net::XMPP' => '1.02',
'NetAddr::IP' => '3',
'Object::InsideOut' => '3.07',
'POE' => '0.9',
'POE::Component::Child' => '0',
'Test::Simple' => '0.62',
'XML::Simple' => '0',
'YAML::Syck' => '0',
},
create_makefile_pl => 'passthrough',
license: perl
resources:
license: http://dev.perl.org/licenses/
requires:
Data::Dump: 0
Date::Parse: 1.16
File::ShareDir: 0.05
FormValidator::Simple: 0
Getopt::Lucid: 0.16
Module::Build: 0
Net::Jabber: undef
Net::XMPP: 1.02
NetAddr::IP: 3
Object::InsideOut: 3.07
POE: 0.9
POE::Component::Child: 0
Scalar::Util: 1.18
Test::Simple: 0.62
XML::Simple: 0
YAML::Syck: 0
provides:
machines.
DEPENDENCIES
'Data::Dump' => '0',
'TimeDate' => '1.16',
'FormValidator::Simple' => '0',
'Getopt::Lucid' => '0.16',
'Scalar::List::Utils' => '1.18',
'Module::Build' => '0',
'Net::Jabber' => 'undef',
'Net::XMPP' => '1.02',
'NetAddr::IP' => '3',
'Object::InsideOut' => '3.07',
'Test::Simple' => '0.62',
'YAML::Syck' => '0'
USING
Passive Agents:
One creates a script, see tail_agent.pl, that loads up a TCLI
lib/Agent/TCLI/Base.pm view on Meta::CPAN
=cut
my @do_verbose :Field
:Arg('Name' => 'do_verbose', 'Default' => sub { print (@_) } )
:Acc('do_verbose')
:Type('CODE');
sub _set_err {
my ($self, $args) = @_;
$self->set(\@err, $args);
$self->Verbose("Err called");
return undef;
}
=back
=head2 METHODS
=over
=item Verbose (<message>, [ <level>, <dump_var> ] )
lib/Agent/TCLI/Base.pm view on Meta::CPAN
}
};
}
elsif ( $action eq 'pop' )
{
$handler = sub {
my $self = shift;
return ( pop( @{ $self->$accessor } ) )
if defined($self->$accessor);
return undef;
};
}
elsif ( $action eq 'shift' )
{
$handler = sub {
my $self = shift;
return ( shift (@{ $self->$accessor } ) )
if defined($self->$accessor);
return undef;
};
}
elsif ( $action eq 'unshift' )
{
$handler = sub {
my $self = shift;
if ( defined($self->$accessor) )
{
return ( unshift( @{ $self->$accessor }, @_ ) );
}
lib/Agent/TCLI/Control.pm view on Meta::CPAN
{
$thisdepth = -1;
}
}
# Might use thisdepth later to determine better response.
if ( $thisdepth < 0 )
{
$txt .= "Command '".join(' ',@{$args})."' not found";
$code = 404;
$cmd = undef;
$self->Verbose("FindCommand: ".$txt.
") code ($code) thisdepth(".$thisdepth.") \n");
$self->Verbose("FindCommand: working c array \n",2,\@c);
$self->Verbose("FindCommand: current registered_commands hash \n",2,$registered_commands[$$self]);
}
unless ( $txt )
{
$self->Verbose("FindCommand: thisdepth($thisdepth) \n",3,\@c);
lib/Agent/TCLI/Control.pm view on Meta::CPAN
{
# always return something defined.
$txt = '';
$code = 200;
}
else
{
$txt .= "Commands not found";
$code = 404;
# %cmds = undef;
$self->Verbose("ListCommands: Whoooops! \n",1,\@aliases);
}
$self->Verbose("ListCommand: cmds(".(scalar keys %cmds).") txt(".$txt.") \n",1);
return(\%cmds, $txt, $code);
}
=item RegisterCommand
RegisterCommand is an internal object method used to Register
lib/Agent/TCLI/Control.pm view on Meta::CPAN
if ( $command eq 'ip' )
{
if (defined($self->local_address))
{
$txt = $self->local_address;
$code = 200;
}
else
{
$txt = 'Local ip address is undefined.' ;
$code = 400;
}
}
$request->Respond( $kernel, $txt, $code );
return ();
} #end sub exit
=item help
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# # some other object
# else
# {
# $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;
# }
# }
# }
#
lib/Agent/TCLI/Package/Base.pm view on Meta::CPAN
# some other object
else
{
$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;
}
}
}
lib/Agent/TCLI/Testee.pm view on Meta::CPAN
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) = @_;
$id = $self->last_request->id unless ( defined($id) && $id );
return(
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
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
lib/Agent/TCLI/Transport/Test.pm view on Meta::CPAN
# 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);
}
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
if ( $xmpp[$$self]->Connected )
{
$xmpp[$$self]->Disconnect;
$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,
'set' => undef,
'result'=> undef,
},
);
# $_[KERNEL]->alias_remove( $_[OBJECT]->get_alias );
}
sub Disconnected {
my ($kernel, $self, $count ) =
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
sub JoinChatRoom {
my ($kernel, $self, $room, $server, $secret) =
@_[KERNEL, OBJECT, ARG0, ARG1, ARG2];
$self->Verbose("JoinChatroom: $room at $server ",2);
$self->xmpp->MUCJoin(
'room' => $room,
'server' => $server,
'nick' => $self->jid->GetUserID,
'password' => defined($secret) ? $secret : undef,
);
}
sub Login {
my ($kernel, $self, ) =
@_[KERNEL, OBJECT, ];
my $txt = '';
# make connection
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
=cut
sub send_presence {
my ($kernel, $self, $args) =
@_[KERNEL, OBJECT, ARG0];
my $xmpp = $xmpp[$$self];
# get params or use defaults
my $status = defined($args->{'status'}) ? $args->{'status'} : 'Online';
my $priority = defined($args->{'priority'}) ? $args->{'priority'} : '8';
my $to = defined($args->{'to'}) ? $args->{'to'} : undef;
my $type = defined($args->{'type'}) ? $args->{'type'} : 'available';
$self->Verbose( "send_presence: type($type) status($status) priority($priority) \n");
# SetPresence(to=>string|JID
# from=>string|JID,
# type=>string,
# status=>string,
# priority=>integer,
# meta=>string,
lib/Agent/TCLI/Transport/XMPP.pm view on Meta::CPAN
}
# IQ, treat like a normal message
elsif ( $type eq 'get' )
{
$control_id = $user->GetJID('full').'-'.$type;
}
else
{
$self->Verbose("GetControlForNode: BAD TYPE ignoring node");
return(undef);
}
my $control = $self->GetControl($control_id, $user->GetJID('base'), $user_protocol);
# If not auth, no control,
unless ($control)
{
$self->Verbose("GetControlForNode: No Control!!!!");
return (0);
};
t/TCLI.Command.GetoptLucid.t view on Meta::CPAN
$opt2 = $test2->Validate($poe_kernel, $request);
is($opt2->{'paramA'},'AAAAA',"$testee paramA ok");
is($opt2->{'test_verbose'},1,"$testee verbose ok");
# Validate with no args
$request->args([ ]);
$opt1 = $test1->Validate($poe_kernel, $request);
is($opt1->{'paramint'},undef,"$testee paramint ok");
is($opt1->{'test_verbose'},undef,"$testee verbose ok");
$request->args([ ]);
$opt2 = $test2->Validate($poe_kernel, $request);
# Can't test for defaults without a package, so this is still undef
is($opt2->{'paramA'},undef,"$testee paramA ok");
is($opt2->{'test_verbose'},undef,"$testee verbose ok");
t/TCLI.Control.t view on Meta::CPAN
is($test1->shift_myarray(),'one','$test1->shift_myarray ');
is_deeply($test1->get_myarray,[ 'two', 'three', 'four', ], '$test1->get_myarray');
is($test1->depth_myarray,3, '$test1->depth_myarray ');
is($test1->print_myarray,'two three four', '$test1->print_myarray');
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 ');
# tests for empty arrays and automethods
is($test1->get_myarray2(),undef,'$test1->get_myarray2 autoload ');
is($test1->depth_myarray2,0, '$test1->depth_myarray2 ');
is($test1->print_myarray2,'', '$test1->print_myarray2');
ok($test1->push_myarray2('two','three'), '$test1->push_myarray2 ');
is_deeply($test1->get_myarray2,[ 'two', 'three', ], '$test1->get_myarray2 ');
is($test1->get_myarray3(),undef,'$test1->get_myarray3 autoload ');
is($test1->shift_myarray3(),undef,'$test1->shift_myarray3 ');
is($test1->pop_myarray3(),undef,'$test1->pop_myarray3 ');
ok($test1->unshift_myarray3('two','three'), '$test1->push_myarray3 ');
is_deeply($test1->get_myarray3,[ 'two', 'three', ], '$test1->get_myarray3 ');
$poe_kernel->run;
t/TCLI.Package.Base.t view on Meta::CPAN
# for init 'name' => 'test1',
ok($test2->name('test2'),'$test2->name mutator ');
is($test2->name,'test2', '$test2->name accessor from mutator');
# Test verbose get-set methods
is($test1->verbose,0, '$test1->verbose get from init args');
# for init 'verbose' => '0',
ok($test2->verbose(1),'$test2->verbose set ');
is($test2->verbose,1, '$test2->verbose get from set');
is($test1->Verbose("ok"),undef,'$test1->Verbose returns undef');
like($test2->Verbose("ok"),qr(ok),'$test1->Verbose returns ok');
is($test2->verbose(0),0,'$test2->verbose set 0');
$c1 = $test1->commands;
# Test commands accessor-mutator methods
is(ref($c1),'HASH', '$test1->commands accessor from init args');
is(ref($c1->{'cmd1'}),'Agent::TCLI::Command',' $test1->commands{cmd1} isa Agent::TCLI::Command');
is(ref($c1->{'cmd2'}),'Agent::TCLI::Command',' $test1->commands{cmd2} isa Agent::TCLI::Command');
t/TCLI.Transport.Test.t view on Meta::CPAN
#print "testee->verbose(".$testee->verbose." )\n";
#print "testpackage->verbose(".$testpackage->verbose." )\n";
ok($test1->verbose(1),'$test1->verbose set ');
is($test1->verbose ,1, '$test1->verbose get from set');
like($test1->Verbose("ok"),qr(ok),'$test1->Verbose returns ok');
is($test1->verbose(0),0,'$test1->verbose set 0');
is($test1->verbose,0,'$test1->verbose get from set');
is($test1->Verbose("ok"),undef,'$test1->Verbose returns undef');
ok($test1->verbose(\$verbose),'$test1->verbose set back');
$testee->ok('status');
my $status = $testee->get_responses('',5);
like($status,qr(TCLI.Transport.Test.t),'responses retrieved');
( run in 3.576 seconds using v1.01-cache-2.11-cpan-d80b1682f3f )