Agent-TCLI
view release on metacpan or search on metacpan
lib/Agent/TCLI/Control.pm view on Meta::CPAN
{
$self->set(\@prompt, $id[$$self]." [".$hostname[$$self]."]: ");
}
}
=item Register
Register is an internal object method used to register commands with the Control.
=cut
sub Register {
my $self = shift;
$self->Verbose("Register: params",4,@_);
my %cmd = validate( @_, {
help => { type => Params::Validate::SCALAR }, #required
usage => { type => Params::Validate::SCALAR }, #required
topic => { optional => 1, type => Params::Validate::SCALAR },
name => { type => Params::Validate::SCALAR }, #required
command => { type => ( Params::Validate::SCALAR | Params::Validate::CODEREF ) }, #required
contexts => { optional => 1, type => Params::Validate::HASHREF },
call_style => { optional => 1, type => Params::Validate::SCALAR },
# start => { optional => 1, type => Params::Validate::CODEREF },
handler => { optional => 1, type => Params::Validate::SCALAR },
# stop => { optional => 1, type => Params::Validate::CODEREF },
} );
# Set up a default contexts if one not provided.
$cmd{'contexts'} = { 'ROOT' => $cmd{'name'} } unless (defined ( $cmd{'contexts'}) );
$self->Verbose("Register: name ".$cmd{'name'} );
$self->RegisterContexts(\%cmd);
# # Don't want these in loop, since they only should get added once.
# push ( @{ $starts[$$self] }, \%cmd ) if ( defined ( $cmd{'start'} ) );
# push ( @{ $handlers[$$self] }, \%cmd ) if ( defined ( $cmd{'handler'} ) );
# push ( @{ $stops[$$self] }, \%cmd ) if ( defined ( $cmd{'stop'} ) );
$self->Verbose("Register: commands \n",5,$registered_commands[$$self]);
return 1;
}
=item RegisterContexts
RegisterCotexts is an internal object method used to register contexts for
commands with the Control.
=cut
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};
if ( $c3 eq '.' )
{
$self->Verbose( "RegisterContext:3.: Adding command "
.$v3." in context ".$c1."->".$c2." ");
$registered_commands[$$self]{ $c1 }{ $c2 }{ $v3 }{'.'} = $cmd;
}
else
{
$self->Verbose( "RegisterContext:3: Adding command "
.$v3.
" in context ".$c1."->".$c2."->".$c3);
$registered_commands[$$self]{ $c1 }{ $c2 }{ $c3 }{ $v3 }{'.'} = $cmd;
}
}
}
elsif ( ( ref( $v2 ) =~ /ARRAY/ ) )
{
foreach my $v2c ( @{$v2})
{
$self->Verbose( "RegisterContext:2a: Adding command "
.$v2c." in context ".$c1."->".$c2." ");
$registered_commands[$$self]{ $c1 }{ $c2 }{ $v2c }{'.'} = $cmd;
}
}
elsif ( $c2 eq '.' )
{
$self->Verbose( "RegisterContext:2.: Adding command "
.$v2." in context ".$c1."->");
$registered_commands[$$self]{ $c1 }{ $v2 }{'.'} = $cmd;
}
else
{
$self->Verbose( "RegisterContext:2: Adding command "
.$v2.
" in context ".$c1."->".$c2." ");
$registered_commands[$$self]{ $c1 }{ $c2 }{ $v2 }{'.'} = $cmd;
}
}
}
elsif ( ( ref( $v1 ) =~ /ARRAY/ ) )
{
foreach my $v1c ( @{$v1})
{
$self->Verbose( "RegisterContext:1a: Adding command "
.$v1c." in context ".$c1." ");
$registered_commands[$$self]{ $c1 }{ $v1c }{'.'} = $cmd;
}
}
else
{
lib/Agent/TCLI/Control.pm view on Meta::CPAN
}
}
}
elsif ( ref($commands) eq 'HASH' )
{
foreach my $cmd ( values %{ $commands } )
{
if(ref $cmd eq 'HASH') {
$self->Register($cmd);
} elsif ( ref($cmd) =~ /Agent::TCLI::Command/ ) {
$self->RegisterCommand($cmd, $package);
} else {
$txt = "Parameter 'commands' contains illegal element";
}
}
}
else
{
$self->Verbose( "RegisterPackage: Bad package $package->dump(1) ",0 );
$self->Verbose( "RegisterPackage: Bad package commands ref(".ref($commands).") dump",0,$commands );
$txt = "Bad package $package";
}
return $txt;
}
=item _start
POE event to load up any initialization routines for commands.
=cut
sub _start {
my ($kernel, $self, $session) =
@_[KERNEL, OBJECT, SESSION];
if (!defined( $self->id ))
{
$self->Verbose("_start: OIO not done re-starting");
$kernel->yield('_start');
return;
}
$kernel->alias_set("$id[$$self]");
$self->Verbose("_start: Starting commands start routines \n");
foreach my $startcmd ( @{ $starts[$$self] } ) {
if ( ref($startcmd) eq 'HASH' )
{
if (defined ($startcmd->{'start'})) {
$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.
# The handler is the name of the event, and the command is the session that
# will handle the event.
# Often the handler name will not be the actual command name.
# TODO, this isn't doing anything right now. Should it? Or are we doing it in the
# _starts session creation....
$self->Verbose("_start: Insert command handler states \n");
foreach my $command ( @{ $handlers[$$self] } ) {
# if the command is not defined, the handler is assumed to be pre-loaded
if ( ref($command->{'command'}) =~ /CODE/ ) {
$self->Verbose("_start:\tregistering ".$command->{'name'}." 's handler $command->{'handler'} \n", 2 );
$kernel->state( $command->{'handler'} , $command->{'command'} );
}
}
# unless ($heap->{no_std_tie}) {
# $self->Verbose "tie STDOUT and STDERR \n" if VERBOSE;
# tie *STDOUT, __PACKAGE__."::Output", 'stdout', \&jabber_send_msg;
# tie *STDERR, __PACKAGE__."::Output", 'stderr', \&jabber_send_msg;
# }
#
# if ($heap->{ties}) {
# foreach (@{$heap->{ties}}) {
# $self->Verbose "tie $_ \n" if VERBOSE;
# tie *$_, __PACKAGE__."::Output", $_, \&jabber_send_msg;
# }
# }
if( $self->session )
{
$self->set(\@start_time, time() );
$self->Verbose( "_started: up at ".$self->start_time.
" _start completed. \n\n");
}
} # End sub _start
=item stop
Poe state that is mostly just a placeholder.
=cut
sub _stop {
my ($kernel, $self, $session) = @_[KERNEL, OBJECT, SESSION];
$self->Verbose("Stopping ".$self->id );
return ('_stop '.$self->id )
}
lib/Agent/TCLI/Control.pm view on Meta::CPAN
{
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
A POE event to execute the help command. Takes a request object as an ARG0.
Responds with the properly formatted help output.
=cut
sub help {
my ($kernel, $self, $sender, $request,) =
@_[KERNEL, OBJECT, SENDER, ARG0,];
$self->Verbose("help: \t"." with context(".$self->print_context.")");
$self->Verbose("help: command(".$request->command->[0].") args[".
$request->print_args."] input(".$request->input.")", 3);
my $command = $request->command->[0];
my (@help, $cmd, $cmds, $context, $txt, $code);
# No specific request, print list of commands with usage.
if ( not defined($request->args->[0]) )
{
($cmds, $txt, $code) = $self->ListCommands();
if ( $code == 200 )
{
$txt = "The following commands are available in this context. \n";
foreach $cmd ( sort keys %{$cmds} )
{
$self->Verbose("help: cmd($cmd) ");
# Need to eliminate aliases by checking something.....
$txt .= "\t".$cmd." - ".$cmds->{$cmd}->help." \n"
if ($cmds->{$cmd}->name =~ /$cmd/ ||
$cmds->{$cmd}->topic !~ /general/
);
}
}
($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 )
{
@help = ( @{$self->context}, @{$request->args} );
unshift(@help,'/') if ($help[0] ne '/');
}
($cmd, $context, $txt, $code) = $self->FindCommand(\@help);
# FindCommand eats @help (as args) and we need what it found in context
@help = reverse(@{$context});
my $on = join(' ',@help);
if (defined($cmd) && defined($cmd->help) )
{
$txt = "Help for command '".$on."' Use 'manual ".$on."' for more info.\n";
$txt .= "\tUsage: ".$cmd->usage."\n";
$txt .= $cmd->help."\n";
if (defined( $cmd->parameters ) )
{
$txt .= "Parameters \n";
foreach my $parameter ( sort keys %{$ cmd->parameters } )
{
$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
sub manual {
my ($kernel, $self, $sender, $request,) =
@_[KERNEL, OBJECT, SENDER, ARG0,];
$self->Verbose("manual: \t"." with context(".$self->print_context.")");
$self->Verbose("manual: command(".$request->command->[0].") args[".
$request->print_args."] input(".$request->input.")", 3);
my $command = $request->command->[0];
my (@manual, $cmd, $cmds, $context, $txt, $code);
if ( $request->args->[0] eq '/' )
{
@manual = @{$request->args};
}
elsif ( $request->depth_args >= 1 )
{
@manual = ( @{$self->context}, @{$request->args} );
unshift(@manual,'/') if ($manual[0] ne '/');
}
else
{
$txt = "Manual requires an argument";
$code = 400;
$request->Respond($kernel, $txt, $code );
return;
}
($cmd, $context, $txt, $code) = $self->FindCommand(\@manual);
# FindCommand eats @manual (as args) and we need what it found in context
@manual = reverse(@{$context});
if (defined($cmd) && defined($cmd->manual) )
{
$txt = "Manual for command '".join(' ',@manual)."' \n";
$txt .= "\tUsage: ".$cmd->usage."\n";
$txt .= $cmd->manual."\n";
# TODO Parameter print method to format better output.
}
elsif (defined($cmd) && defined($cmd->help ) )
{
$txt = "No manual defined. Here is help for command '".
join(' ',@manual)."' \n";
$txt .= "\tUsage: ".$cmd->usage."\n";
$txt .= $cmd->help."\n";
}
elsif (defined($cmd) )
{
$txt = "Darn! The lazy programmer didn't supply a manual or help!"
}
if (defined( $cmd->parameters ) )
{
$txt .= "Parameters:\n";
foreach my $parameter ( sort keys %{$ cmd->parameters } )
{
$txt .= "\n".$cmd->parameters->{ $parameter }->name." \n";
$txt .= $cmd->parameters->{ $parameter }->manual;
}
}
elsif ( $cmd->handler eq 'establish_context')
{
my ($subcmds, $subtxt, $subcode) = $self->ListCommands(\@manual);
if ( $subcode == 200 )
{
$txt .= "The following sub commands are available: \n";
foreach my $subcmd ( sort keys %{$subcmds} )
{
$self->Verbose("manual: subcmd($subcmd) ");
# 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";
# $txt .= "\tUsage: ".$cmd->usage."\n";
# $txt .= $cmd->manual."\n";
# # TODO Parameter print method to format better output.
# if (defined( $cmd->parameters ) )
# {
# $txt .= "Parameters:\n";
# foreach my $parameter ( sort keys %{$ cmd->parameters } )
# {
# $txt .= "\n".$cmd->parameters->{ $parameter }->name." \n";
# $txt .= $cmd->parameters->{ $parameter }->manual;
# }
# }
# }
# elsif (defined($cmd) && defined($cmd->help ) )
# {
# $txt = "No manual defined. Here is help for command '".$on."' \n";
# $txt .= "\tUsage: ".$cmd->usage."\n";
# $txt .= $cmd->help."\n";
# if (defined( $cmd->parameters ) )
# {
# $txt .= "Parameters \n";
# foreach my $parameter ( sort keys %{$ cmd->parameters } )
# {
# $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 manual
=item exit
A POE event to handle context shift commands exit and /.
It expects a request object parameter.
=cut
sub exit {
my ($kernel, $self, $request, ) =
@_[KERNEL, OBJECT, ARG0, ];
# $self->Verbose("exit: command($args->[0]) args[".scalar($args)
# ."] input($input)", 4);
my $command = $request->command->[0];
$self->Verbose("exit: command($command)");
my $context;
# we're set up to handle '/' as well as exit and '..'
if ($command eq '/' || $command eq 'root' )
{
$context = '/';
}
else
{
# Used to do a lot more here, but pushed it off to change context.
$context = '..';
}
# $request->Respond( $kernel, "exiting: context now ".$context, 200 );
$kernel->yield( 'ChangeContext', $request, $context );
return ();
} #end sub exit
=item dumpcmd
A POE event to handle some debugging in band.
It expects a request object parameter.
=cut
sub dumpcmd {
my ($kernel, $self, $request) =
@_[KERNEL, OBJECT, ARG0];
my $command = $request->command->[0];
my $txt;
# dump them all if no args
if ( $request->ArgsDepth == 0 )
{
foreach my $cmd ( keys %{ $registered_commands[$$self] } )
{
$txt .= $registered_commands[$$self]{$cmd}->dump(1);
}
}
elsif ( $request->ArgsDepth > 0 )
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# }
# # some other object, array or hash
# else
# {
# $var = $self->$attr->{$key};
# $txt .= Dump($var)."\n";
# $code = 200;
# }
# }
# }
# elsif ( $ref =~ qr(ARRAY) )
# {
# my $i = 0;
# foreach my $val ( @{$self->$attr} )
# {
# my $subref = ref( $val );
# # simple scalar
# if ( not $subref )
# {
# $txt .= "$attr ->[ $i ]: ".$val." \n";
# $code = 200;
# }
# # is it an object and show_method is defined?.
# elsif ( $subref =~ qr(::) &&
# blessed($val) &&
# defined($show) )
# {
# $txt .= "$attr: ".$val->$show."\n";
# $code = 200;
# }
# # is it an object with dump? Probably OIO.
# elsif ( $subref =~ qr(::) &&
# blessed($val) &&
# $val->can( 'dump') )
# {
# $var = $val->dump(0);
# $txt .= Dump($var)."\n";
# $code = 200;
# }
# # some other object, array or hash
# else
# {
# $txt .= Dump($val)."\n";
# $code = 200;
# }
# }
# }
# # 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;
# }
# }
# }
#
# # if we didn't find anything at all, then a 404 is returned
# if (!defined($txt) || $txt eq '' )
# {
# $txt = $what.": #!ERROR not found";
# $code = 404;
# }
#
# $request->Respond($kernel, $txt, $code);
#}
#
#=item settings
#
#This POE event handler executes the set commands.
#
#=cut
#
#sub settings { # Can't call it set
# my ($kernel, $self, $sender, $request, ) =
# @_[KERNEL, OBJECT, SENDER, ARG0, ];
#
# my $txt = '';
# my ($param, $code);
# my $command = $request->command->[0];
# # called directly because $command may be an alias and not the real name
# my $cmd = $self->commands->{'set'};
#
# # TODO a way to unset/restore defaults....
#
# # break down and validate args
# return unless ($param = $cmd->Validate($kernel, $request) );
#
# $self->Verbose("set: param dump",1,$param);
#
# # Get meta data
# my $meth = $self->meta->get_methods();
#
# foreach my $attr ( keys %{$param} )
# {
# # param will have all fields defined, gotta skip the empty ones.
# # Can't use ne due to NetAddr::IP bug
# next unless (defined($param->{$attr})
## && !($param->{$attr} eq '') # diabled, since we should be OK now.
# );
#
# $self->Verbose("settings: setting attr($attr) => ".
# $param->{$attr}." ");
#
# # is there a field type object for this attr?
# if ( ref($param->{$attr}) eq '' &&
# exists( $meth->{$attr} ) &&
# 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( $@ )
# {
# $@ =~ qr(Usage:\s(.*)$)m ;
# $txt = $1;
# $self->Verbose('set: new '.$class.' got ('.$txt.') ');
# $request->Respond($kernel, "Invalid: $attr !", 400);
# return;
# }
# $txt .= "Set ".$attr." to ".$param->{$attr}." \n";
# $code = 200;
#
# }
# else
# {
# eval { $self->$attr( $param->{$attr} ) };
# if( $@ )
# {
# $@ =~ qr(Usage:\s(.*)$)m ;
# $txt = $1;
# $self->Verbose('set: $self->'.$attr.'( '.$param.'->{ '.
# $attr.' } got ( '.$txt.') ');
# $request->Respond($kernel, "Invalid: $attr !", 400);
# return;
# }
# $txt .= "Set ".$attr." to ".$param->{$attr}." \n";
# $code = 200;
# }
# }
#
# if (!defined($txt) || $txt eq '' )
# {
# $txt = "Invalid: ".join(', ',keys %{$param} );
# $code = 404;
# }
#
# $request->Respond($kernel, $txt, $code);
#}
=item print_context
An object method to get the current context in string form. It has no parameters.
=cut
sub print_context {
my $self = shift;
return ( join(' ', @{$context[$$self]} ) );
} # End sub print_context
=item push_context
An private object method to push onto the current context. It has no parameters.
=cut
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 ) );
}
}
=item pop_context
An private object method to pop from the current context. It has no parameters.
=cut
sub pop_context # :Restricted
{
my $self = shift;
my $context = pop( @{$context[$$self]} );
# context should never be empty. Make root if empty.
if ( scalar( @{$context[$$self]} ) == 0 )
{
$self->context( ['ROOT'] );
}
return ($context);
}
=item depth_context
An object method to return the context depth. It has no parameters.
If the context is root ('ROOT') context depth wil return 0 even
though context [0] is populated with 'ROOT'.
=cut
sub depth_context {
my $self = shift;
my $depth;
if ( $self->context->[0] eq 'ROOT' )
{
$depth = 0;
}
else
{
$depth = scalar( @{ $context[$$self] } );
}
return ( $depth );
}
=item _default
A POE event handler to handle events gone astray. Only does something
when verbose is turned on.
=cut
sub _default {
my ($kernel, $self, ) =
( run in 0.544 second using v1.01-cache-2.11-cpan-39bf76dae61 )