Agent-TCLI
view release on metacpan or search on metacpan
lib/Agent/TCLI/Control.pm view on Meta::CPAN
}
# if available, register requested command packages
$self->Verbose( "init: Registering user packages \n" );
if ( defined($packages[$$self] ) )
{
my $txt;
foreach my $package (@{ $packages[$$self] })
{
my $txt = $self->RegisterPackage($package);
croak ($txt) if ($txt); # Load fail on start MUST die.
}
} # end if packages
# Register user commands, if requested #{{{
# $self->Verbose( "init: Registering user commands \n" );
#
# if( ref( $commands[$$self] ) =~ /ARRAY/i ) {
#
# foreach my $cmd (@{ $commands[$$self] }) {
# if ( ref($cmd) eq 'HASH') {
# $self->register($cmd);
# } elsif ( ref($cmd) =~ /Agent::TCLI::Command/ ) {
# $self->register_command($cmd);
# } else {
# $self->Verbose("init: Parameter 'commands' contains bad element");
# $self->Verbose("init: Dump of commands ", 4, $commands[$$self]);
# }
# } #end foreach
#
# } else {
#
# $self->Verbose("init: User commands not an array ref, not loaded");
# $self->Verbose("init: Dump of commands ", 4, $commands[$$self]);
#
# } #end if commands
if ( defined( $hostname[$$self] ) )
{
$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);
lib/Agent/TCLI/Control.pm view on Meta::CPAN
{
# TODO Still need a better parser.
# Parsewords chokes on single singlequotes.
$input =~ s/'//;
# parsewords also parses whitespace at the beginning poorly.
$input =~ s/^\s*//;
# Parsewords doesn't handle trailing backslashes well.
$input =~ s/\\$//;
@args = shellwords($input);
}
# substitute for help
$args[0] = 'help' if ($args[0] eq '?');
# # 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.
#
# # $args[0] will always be the command word to execute, but may have
# # not been the first word entered if the command is nested deep in a
# # context. If a command needs to determine exactly how it was called
# # then it needs to reparse $input.
my ($cmd, $context, $txt, $code) = $self->FindCommand(\@args);
unless ($code == 404)
{
$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
push( @rargs, $request->command->[0], $request->args );
# Make sure there is input, just in case....
$rinput = defined($request->input) ? $request->input :
join(' ',$request->command->[0],$request->args);
# do it
($txt, $code) = $self->DoSub($cmd, \@rargs, $rinput );
$request->Respond( $kernel, $txt, $code);
return;
}
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';
$code = 400;
}
$self->Verbose("Execute: Got ".$txt." from in ".$self->id." ", 3 );
if ( ref($request) =~ /Request/ )
{
$request->Respond($kernel, $txt, $code );
}
else
{
my $response = Agent::TCLI::Response->new(
'body' => $txt,
'code' => $code,
);
$kernel->yield('AsYouWished' => $response ) ;
}
} #end sub Execute
=item DoSub
This internal object method performs the actual execution of commands
that are only small subs.
=cut
sub DoSub {
my ($self, $cmd, $args, $input) = @_;
$self->Verbose("DoSub: sub ".$cmd->name." \n");
my $txt = eval {
&{$cmd->command}( $args, $input );
};
if($@)
{
$self->Verbose("DoSub: Error (".$@.") \n" );
return ("RUN ERROR: $@", 400);
}
else
{
$self->Verbose("DoSub: sub returned (".$txt.") \n",4 );
}
return ($txt, 200);
}
=item AsYouWished
lib/Agent/TCLI/Control.pm view on Meta::CPAN
=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, ) =
@_[KERNEL, OBJECT, ];
my $oops = "\n\n\n".
"\t OOOO OOOO PPPPPP SSSSSS ## \n".
"\t OO OO OO OO PP PP SS ## \n".
"\tOO OO OO OO PP PP SS ## \n".
"\tOO OO OO OO PPPPPP SSSSSS ## \n".
"\tOO OO OO OO PP SS ## \n".
"\t OO OO OO OO PP SS \n".
"\t OOOO OOOO PP SSSSSS ## \n";
$self->Verbose($oops);
$self->Verbose("\n\nDefault caught an unhandled $_[ARG0] event.\n");
$self->Verbose("The $_[ARG0] event was given these parameters:");
$self->Verbose("ARG1 dumped",1,$_[ARG1]) if defined($_[ARG1]);
$self->Verbose("ARG2 dumped",1,$_[ARG2]) if defined($_[ARG2]);
return(0);
}
=item _default_commands
A private object method that has all the default commands.
The ones we just can't live without. Well, maybe not all the ones we can't
live without, but all the ones that have actually be written so far.
=cut
sub _default_commands :Private {
my $self = shift;
my $dc = {
'echo' => Agent::TCLI::Command->new(
'name' => 'echo',
'help' => 'Return what was said.',
'usage' => 'echo <something> or /echo ...',
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => {'UNIVERSAL' => 'echo'},
'call_style'=> 'state',
'handler' => 'general'
),
'Hi' => Agent::TCLI::Command->new(
'name' => 'Hi',
'help' => 'Greetings',
'usage' => 'Hi/Hello',
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => {'ROOT' => [ qw(Hi hi Hello hello)]},
'call_style'=> 'state',
'handler' => 'general'
),
'context' => Agent::TCLI::Command->new(
'name' => 'context',
'help' => "displays the current context",
'usage' => 'context or /context',
'manual' => "Context can be somewhat difficult to understand when one thinks of normal command line interfaces that often retain context differently. ".
"Context is a way of nesting commands, much like a file directory, to make it easier to navigate. There are a few commands, such as 'help' or 'exit' that are global, ".
"but most commands are available only within specific contexts. Well written packages will collect groups of similar commands within a context. ".
"For instance, if one had package of attack commands, one would put them all in an 'attack' context. Instead of typing 'attack one target=example.com', ".
"one could type 'attack' to change to the attack context then type 'one target=example.com' followed by 'two target=example.com' etc. \n\n".
"Furthermore, a well written package will support the setting of default parameters for use within a context. One can then say: \n ".
"\tattack \n\tset target=example.com \n\tone \n\ttwo \n\t...\n\n".
"The full command 'attack one target=example.com' must always be supported, but using context makes it easier to do repetitive tasks manually as well as ".
"allow one to navigate through a command syntax that one's forgotten the details of without too much trouble. \n\n".
"Context has a sense of depth, as in how many commands one has in front of whatever one is currently typing. ".
"An alias to the context command is 'pwd' which stands for Present Working Depth. ".
"Though it may make the Unix geeks happy, they should remember that this is not a file directory structure that one is navigating within.",
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => {'UNIVERSAL' => [ qw( context pwd ) ]},
'call_style'=> 'state',
'handler' => 'general'
),
'Verbose' => Agent::TCLI::Command->new(
'name' => 'Verbose',
'help' => "changes the verbosity of output to logs",
'usage' => 'Verbose',
'topic' => 'admin',
'command' => 'pre-loaded',
'contexts' => {'UNIVERSAL' => 'Verbose'},
'call_style'=> 'state',
'handler' => 'general'
),
'debug_request' => Agent::TCLI::Command->new(
'name' => 'debug_request',
'help' => 'show what the request object contains',
'usage' => 'debug_request <some other args>',
'topic' => 'admin',
'command' => 'pre-loaded',
'contexts' => {'UNIVERSAL' => 'debug_request'},
'call_style'=> 'state',
'handler' => 'general'
),
'help' => Agent::TCLI::Command->new(
'name' => 'help',
'help' => 'Display help about available commands',
'usage' => 'help [ command ] or /help',
'manual' => 'The help command provides summary information about running a command and the parameters the command accepts. Help with no arguments will list the currently available commands. Help is currently broken in that it only operates wi...
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => {'UNIVERSAL' => 'help'},
'call_style'=> 'state',
'handler' => 'help'
),
'manual' => Agent::TCLI::Command->new(
'name' => 'manual',
'help' => 'Display detailed help about a command',
'usage' => 'manual [ command ]',
'manual' => 'The manual command provides detailed information about running a command and the parameters the command accepts. Manual is currently broken in that it only operates within the existing context and cannot be called with a full con...
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => {'UNIVERSAL' => ['manual', 'man'] },
'call_style'=> 'state',
'handler' => 'manual'
),
'status' => Agent::TCLI::Command->new(
'name' => 'status',
'help' => 'Display general TCLI control status',
'usage' => 'status or /status',
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => {'UNIVERSAL' => 'status'},
'call_style'=> 'state',
'handler' => 'general'
),
'/' => Agent::TCLI::Command->new(
'name' => 'root',
'help' => "exit to root context, use '/command' for a one time switch",
'usage' => 'root or / ',
'manual' => "root, or '/' for the Unix geeks, will change the context back to root. See 'manual context' for more information on context. ".
"Unless otherwise noted, changing to root context does not normally clear out any default settings that were established in that context. \n\n".
"One can preceed a command directly with a '/' such as '/exit' to force the root context. ".
"Sometimes a context may independently process everything said within the context and, if misbehaving, doesn't provide a way to leave the context. ".
"Using '/exit' or '/help' should always work. The example package Eliza is known to have trouble saying Goodbye and exiting properly.",
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => { 'UNIVERSAL' => ['/','root'] },
'call_style'=> 'state',
'handler' => 'exit',
),
# {
# 'name' => 'load',
# 'help' => 'Load a new control package',
# 'usage' => 'load < PACKAGE >',
# 'topic' => 'admin',
# 'command' => sub {return ("load is currently diabled")}, #\&load,
# 'call_style'=> 'sub',
# },
# {
# 'name' => 'listcmd',
# 'help' => 'Dump the registered commands in their contexts',
# 'usage' => 'listcmd (<context>)',
# 'topic' => 'admin',
# 'command' => 'pre-loaded',
# 'contexts' => {'UNIVERSAL'},
# 'call_style' => 'state',
# 'handler' => 'listcmd',
# },
'dumpcmd' => Agent::TCLI::Command->new(
'name' => 'dumpcmd',
'help' => 'Dump the registered command hash information',
'usage' => 'dumpcmd <cmd>',
'topic' => 'admin',
'command' => 'pre-loaded',
'contexts' => {'UNIVERSAL' => 'dumpcmd'},
'call_style'=> 'state',
'handler' => 'dumpcmd',
),
'nothing' => Agent::TCLI::Command->new(
'name' => 'nothing',
'help' => 'Nothing is as it seems',
'usage' => 'nothing',
'topic' => 'general',
'contexts' => {'ROOT' => 'nothing'},
'command' => sub { return ("You said nothing, try help") },
'call_style'=> 'sub',
),
'exit' => Agent::TCLI::Command->new(
'name' => 'exit',
'help' => "exit the current context, returning to previous context",
'usage' => 'exit or /exit',
'manual' => "exit, or '..' for the Unix geeks, will change the context back one level. See 'manual context' for more information on context. ".
"Unless otherwise noted, leaving a context does not normally clear out any default settings that were established in that context. \n\n",
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => {'UNIVERSAL' => [ qw(exit ..)] },
'call_style'=> 'state',
'handler' => 'exit',
),
'ip' => Agent::TCLI::Command->new(
'name' => 'ip',
'help' => 'Returns the local ip address',
'usage' => 'ip',
'topic' => 'net',
'command' => 'pre-loaded',
'contexts' => {'ROOT' => 'ip' },
'call_style'=> 'state',
'handler' => 'net'
),
'Control' => Agent::TCLI::Command->new(
'name' => 'Control',
'help' => 'show or set Control variables',
'usage' => 'Control show local_address',
'topic' => 'admin',
'command' => 'pre-loaded',
'contexts' => {'ROOT' => 'Control' },
'call_style'=> 'state',
'handler' => 'establish_context'
),
'show' => Agent::TCLI::Command->new(
'name' => 'show',
'help' => 'show Control variables',
'usage' => 'Control show local_address',
'topic' => 'admin',
'command' => 'pre-loaded',
'contexts' => {'Control' => 'show' },
'call_style'=> 'state',
'handler' => 'establish_context'
),
};
return ( $dc );
}
=item _automethod
Some transports may need to store extra state information related to the
control. Rather than force them to maintain some sort of lookup table,
the Control object can have attributes generated on the fly.
This operates the same as for Request objects and within the
transports themselves. It is exected that the Transport
documentation will describe what is being stored in the Control.
=cut
1;
=back
=head3 INHERITED METHODS
This module is an Object::InsideOut object that inherits from Agent::TCLI::Base. It
inherits methods from both. Please refer to their documentation for more
details.
=head1 AUTHOR
Eric Hacker E<lt>hacker at cpan.orgE<gt>
=head1 BUGS
SHOULDS and MUSTS are currently not enforced.
Test scripts not thorough enough.
Probably many many others.
=head1 LICENSE
Copyright (c) 2007, Alcatel Lucent, All rights resevred.
This package is free software; you may redistribute it
and/or modify it under the same terms as Perl itself.
=cut
( run in 0.902 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )