Agent-TCLI
view release on metacpan or search on metacpan
lib/Agent/TCLI/Control.pm view on Meta::CPAN
$cmd =
$registered_commands[$$self]{$c[0]}{'ALL'}{'.'};
$thisdepth = 1;
}
# Universal context
elsif (
defined( $registered_commands[$$self]{'GROUP'}{$c[1]}
) )
{
$cmd =
$registered_commands[$$self]{'GROUP'}{$c[1]}{'.'};
$thisdepth = 1;
}
# $c[1] Globally Universal
elsif (
defined($registered_commands[$$self]{'UNIVERSAL'}{$c[1]} )
)
{
$cmd =
$registered_commands[$$self]{'UNIVERSAL'}{$c[1]}{'.'};
$thisdepth = 1;
}
else
{
$thisdepth = -2;
}
}
if ( $thisdepth < 0 && defined($c[0]) && $depth == 0 )
{
# Root context
if ( defined($registered_commands[$$self]{'ROOT'}{$c[0]} )
)
{
$cmd =
$registered_commands[$$self]{'ROOT'}{$c[0]}{'.'};
$thisdepth = 0;
}
# There is no 'ALL' handling at the root context. Make a case and I'll consider it.
# There is no Universal only in root context. Make a case and I'll consider it.
# Globally Universal
elsif ( defined(
$registered_commands[$$self]{'UNIVERSAL'}{$c[0]}
) )
{
$cmd =
$registered_commands[$$self]{'UNIVERSAL'}{$c[0]}{'.'};
$thisdepth = 0;
}
else
{
$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);
# take off the args, but leave the command and the context.
@{$args} = splice(@c,$thisdepth+1);
$self->Verbose("FindCommand: Found(".$cmd->name.
") for ".$id[$$self]." with thisdepth($thisdepth) args\n",2,$args);
# always return something defined.
$txt = '';
$code = 200;
}
# we want @commands to be reversed.
@c = reverse(@c);
return($cmd, \@c, $txt, $code);
}
=item SortCommands
SortCommands is an internal object method used to sort the commands available
in a context. It returns an array of arrays of alias => cmd object.
=cut
sub SortCommands {
my ($self, $hash ) = @_;
my @cmds;
$self->Verbose("SortCommands: hash dump \n",2,$hash);
# one must remember that the command name is not the alias that
# might be in use in this context. Thus we muct return an array
# of arrays so that we have both the alias and the cmd object.
foreach my $command ( sort keys %{$hash} )
{
push (@cmds, [ $command => $hash->{$command}{'.'} ] )
if ( $command !~ qr(^GROUP|^\.) ); # Ignore .objects and GROUP
}
return (\@cmds);
}
=item ListCommands
ListCommands is an internal object method used to list the commands available
in a context. It calls SortCommands once it has found the right context.
=cut
sub ListCommands {
my ($self, $c ) = @_;
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# elsif ( defined( $registered_commands[$$self]{ 'GROUP' } ) )
# {
# $aliases = $self->SortCommands( $registered_commands[$$self]{ 'GROUP' } );
# }
}
elsif ( @{$c} == 2 )
{
if ( defined( $registered_commands[$$self]{ $c->[0] }{ $c->[1] } ) )
{
push( @aliases , @{ $self->SortCommands( $registered_commands[$$self]{ $c->[0] }{ $c->[1] } ) } );
}
if ( defined( $registered_commands[$$self]{ $c->[0] }{ 'GROUP' } ) )
{
push( @aliases , @{$self->SortCommands( $registered_commands[$$self]{ $c->[0] }{ 'GROUP' } ) } );
}
}
elsif ( @{$c} == 3 )
{
if ( defined( $registered_commands[$$self]{ $c->[0] }{ $c->[1] }{ $c->[2] } ) )
{
push( @aliases , @{ $self->SortCommands( $registered_commands[$$self]{ $c->[0] }{ $c->[1] }{ $c->[2] } ) } );
}
if ( defined( $registered_commands[$$self]{ $c->[0] }{ $c->[1] }{ 'GROUP' } ) )
{
push( @aliases , @{ $self->SortCommands( $registered_commands[$$self]{ $c->[0] }{ $c->[1] }{ 'GROUP' } ) } );
}
}
elsif ( @{$c} == 4 )
{
if ( defined( $registered_commands[$$self]{ $c->[0] }{ $c->[1] }{ $c->[2] }{ $c->[3] } ) )
{
push( @aliases , @{ $self->SortCommands( $registered_commands[$$self]{ $c->[0] }{ $c->[1] }{ $c->[2] }{ $c->[3] } ) } );
}
if ( defined( $registered_commands[$$self]{ $c->[0] }{ $c->[1] }{ $c->[2] }{ 'GROUP' } ) )
{
push( @aliases , @{ $self->SortCommands( $registered_commands[$$self]{ $c->[0] }{ $c->[1] }{ $c->[2] }{ 'GROUP' } ) } );
}
}
$self->Verbose("ListCommands: Aliases dump",2,\@aliases);
foreach my $command ( @aliases )
{
$cmds{ $command->[0] } = $command->[1];
}
$self->Verbose("ListCommands: cmds dump",2,\%cmds);
if ( %cmds )
{
# 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
Agent::TCLI::Package::Command objects directly.
=cut
sub RegisterCommand {
my ($self, $cmd, $package) = @_;
$self->Verbose( "RegisterCommand: ".$cmd->name." " );
# Set a default package if not defined.
$package = defined($package) ? $package."::".$cmd->name :
'Control'."::".$cmd->name;
if ( defined( $registered_commands[$$self]{'registered'}{ $package }) )
{
# We could die here, but then one would have to iterate over each failure
# Though it might be nice to make failure more apparent. A MOTD perhaps?
$self->Verbose( "RegisterCommand: ".$cmd->name." already registered! ",0 );
$self->Verbose( "RegisterCommand: registered_commands dump ",1,$self->registered_commands );
}
else
{
# need to figure out a way to do a reverse lookup on the name...
$registered_commands[$$self]{'registered'}{ $package } = $cmd;
$self->RegisterContexts($cmd);
}
return 1;
}
=item RegisterPackage
RegisterPackage is an internal object method used to register and entire
package of commands. It calls the Package's RawCommands method
to get the list of commands that need to be registered.
=cut
sub RegisterPackage {
my ($self, $package) = @_;
my ($commands, $txt);
$self->Verbose( "RegisterPackage: $package " );
# eval { require "$package" };
# if ($@) {
# $txt = "Bad package $package $@";
# return $txt
# };
$commands = $package->commands();
lib/Agent/TCLI/Control.pm view on Meta::CPAN
{
@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);
# Now get args from input.
if ( ! @args )
{
# 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,
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# @_[KERNEL, OBJECT, ARG0];
#
# my $command = $request->command->[0];
#
# my $txt;
# # TODO this is broken with new commands hash.
# if ( $request->depth_args == 0
# { # dump them all
# foreach my $context ( $registered_commands[$$self] )
# {
# $txt .= "\nCommands in context ".$context." \n\t";
# foreach my $command ( %{ $registered_commands[$$self]{ $context } } )
# {
# $txt .= $registered_commands[$$self]{ $context }{ $command }{'name'}.", ";
# } #end foreach command
# } #end foreach context
# }
# else
# {
# # just dump some in a context
#
# # tHIS SHOULD GRAB AN ARRAY
# my $context = $request->depth_args > 0 ? $request->args->[0] : $thread[$$self]->context;
#
# # if/eslif on size of array.
# # loop over hash1.hash2.hash3.keys getting '.'{'name'}
# # loop over wildcards too
#
# foreach my $cmd ( %{ $registered_commands[$$self]{ $context } } )
# {
# $txt .= $registered_commands[$$self]{ $context }{ $cmd }{'name'}.", ";
# }
# }
# $txt =~ s/,\s$//;
# $request->Respond( $kernel, $txt );
#} #end sub listcmd
#=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
#subcoammnds/args using the 'A*' context. See the Eliza package for an example of
#how to establish that type of context.
#
#=cut
#
#sub establish_context {
# my ($kernel, $self, $sender, $request, ) =
# @_[KERNEL, OBJECT, SENDER, ARG0, ];
# $self->Verbose("establish_context: ".$self->name." for request(".
# $request->id().")");
#
# my $txt;
# # if we have args, then the command is invalid
# if ( $request->depth_args > 0 )
# {
# $txt .= "Invalid input: ".$request->input;
# $self->Verbose("establish_context: Invalid input (".$request->input.")" );
# $request->Respond($kernel, $txt, 404) if $txt;
# return;
# }
#
# # we don't know how deep we're in already. So we'll force a full context shift.
# # by sending the entire command array back, which is revesred.
# my @context = reverse (@{$request->command});
#
# # We don't actualy set the controls context, but let change context do that.
# # It will also inform the user of change.
#
# # Post context back to sender (Control)
# $kernel->call( $sender => 'ChangeContext' => $request, \@context );
# $self->Verbose("establish_context: setting context to "
# .join(' ',@context)." ",2);
#
#}
#
#=item show
#
#This POE event handler i will accept an argument for the setting to show.
#It will also take an argument of all or * and show all settings.
#
#The parameter must be defined in the command entry's parameters or it will
#not be shown. There must also be a OIO Field defined with the same name.
#One may write their own show method if this is not sufficient.
#
#=cut
#
#sub show {
# my ($kernel, $self, $sender, $request, ) =
# @_[KERNEL, OBJECT, SENDER, ARG0, ];
# $self->Verbose("show: request(".$request->id.") ",2);
#
# my ($txt, $code, $what, $var);
# # calling with show as a command, that is the handler for show is show.
# if ( $request->command->[0] eq 'show' ) # cmd1 show arg
# # cmd1 attacks show <arg>
# {
# $what = $request->args->[0];
# }
#
# $self->Verbose("show: what(".$what.") request->args",1,$request->args);
#
# ATTR: foreach my $attr ( keys %{ $self->commands->{'show'}->parameters } )
# {
# if ( $what eq $attr || $what =~ qr(^(\*|all)$))
# {
# if ( $self->can( $attr ) && defined( $self->$attr) )
# {
# my $ref = ref($self->$attr);
# my $show = ( defined($self->parameters ) &&
# defined($self->parameters->{ $attr } ) &&
# defined($self->parameters->{ $attr }->show_method ) )
# ? $self->parameters->{ $attr }->show_method
# : '';
# $self->Verbose("show attr($attr) ref($ref) show($show)",1);
# # simple scalar
# if ( not $ref)
# {
# $txt .= "$attr: ".$self->$attr." \n";
lib/Agent/TCLI/Control.pm view on Meta::CPAN
# {
# $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);
( run in 1.860 second using v1.01-cache-2.11-cpan-39bf76dae61 )