Agent-TCLI
view release on metacpan or search on metacpan
lib/Agent/TCLI/Control.pm view on Meta::CPAN
and Network Administrators are usually forced to manage many more types of
devices than System Administrators. Network Systems also generally require much less
daily contact, so it is important for the user interface to be as helpful
as possible, because the operator has likely forgotten half of the command
syntax.
For functional quality assurance testing, the demands are much more in line with Network
Administration. One will need to plug in a module that tests some sort
of capability, write and run some tests, and then do something else for
a bit while the developers/integrators fix the problems. Thus TCLI attempts
to use the Cisco-like contextual paradigm to provide a user interface to
support testers.
=cut
use warnings;
use strict;
use POE;
use Carp;
use Object::InsideOut qw(Agent::TCLI::Package::Base);
use Agent::TCLI::Request;
use Agent::TCLI::Response;
use Agent::TCLI::Command;
use Agent::TCLI::Parameter;
use Params::Validate;
#use Data::Dump qw(pp);
use Text::ParseWords;
#sub VERBOSE () { 0 }
our $VERSION = '0.030.'.sprintf "%04d", (qw($Id: Control.pm 62 2007-05-03 15:55:17Z hacker $))[2];
=head1 INTERFACE
=head2 ATTRIBUTES
The following attributes are accessible through standard accessor/mutator
methods and may be set as a parameter to new unless otherwise noted.
=over
=item id
ID of control. MUST be unique to all other controls and is the POE kernel alias.
=cut
my @id :Field
:All('id');
=item registered_commands
The collection of registered_commands in the control library. Commands may
not be set, but must added with the register method.
=cut
my @registered_commands :Field :Get('registered_commands');
my @starts :Field :Get('starts');
my @stops :Field :Get('stops');
my @handlers :Field :Get('handlers');
my @start_time :Field
:Get('start_time');
my @user :Field :All('user')
:Type('Agent::TCLI::User');
my @packages :Field :All('packages');
#my @alias :Field :All('alias');
=item auth
Authorization for the user for this control. Must be separate from the
auth in the user object since that might not be the only factor at all times.
=cut
my @auth :Field
:All('auth');
=item type
Type of conversation. MUST be one of these values:
B<instant> => one time (or not specified)
B<chat> => peer to peer chat
B<group> => group chatroom
=cut
my @type :Field( 'All' => 'type' );
=item context
Contains the context of the current Command application for the control.
=cut
my @context :Field
:Type('Array')
:Arg('Name' => 'context', 'Default' => ['ROOT'] )
:Acc('context');
=item owner
Contains the owning session of the control. This allows the control to be
passed around between sessions and whatever session that has it can
send back to the top level originating session.
=cut
my @owner :Field( 'All' => 'owner' );
=item prompt
The promt that the control is displaying, when appropriate.
=cut
my @prompt :Field :All('prompt');
=item local_address
The local IP address of the system
=cut
my @local_address :Field
:All('local_address');
=item hostname
The hostname being used by the control.
=cut
my @hostname :Field
:All('hostname');
=item poe_debug
A flag to set whether to enable poe debugging if installed
=cut
my @poe_debug :Field
:All('poe_debug');
# Holds our session data. Made weak per Merlyn
# http://poe.perl.org/?POE_Cookbook/Object_Methods.
# We also don't take session on init.
#my @session :Field
# :Get('session')
# :Weak;
# Standard class utils are inherited
=back
=head2 METHODS
=over
=cut
sub _preinit :Preinit {
my ($self,$args) = @_;
$args->{'session'} = POE::Session->create(
object_states => [
$self => [qw(
_start
_stop
_shutdown
_default
ControlAddState
control_presence
AsYouWished
ChangeContext
Execute
dumpcmd
establish_context
exit
general
help
manual
net
show
settings
)],
],
'heap' => $self,
);
}
sub _init :Init {
my $self = shift;
# Validate arguments
# $self->Verbose( "spawn: Validating arguments \n" );
# my %args = validate( @_, {
# local_address => { optional => 1 },
# local_port => { optional => 1, default => 42 },
# hostname => { optional => 1, default => hostname() },
# poe_debug => { optional => 1, default => 1 },
# # if not available, silenty fails to load debug
# }
# );
$self->LoadXMLFile();
# Register default commands
$self->Verbose( "init: Registering default commands \n".$self->dump(1),3 );
foreach my $cmd ( values %{ $self->commands } )
{
$self->RegisterCommand($cmd);
}
# 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);
$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 '.' )
lib/Agent/TCLI/Control.pm view on Meta::CPAN
}
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();
if ( ref($commands) eq 'ARRAY')
{
foreach my $cmd (@{ $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";
}
}
}
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 )
}
=item shutdown
POE event to forcibly shutdown the CLI control. It will call the stops for
all registered commnds that requested them. This probably is not necessary,
as their sessions will clean up after themselves.
=cut
sub _shutdown {
my ($kernel, $self, $session) = @_[KERNEL, OBJECT, SESSION];
foreach my $cmd ( @{ $stops[$$self] } ) {
if (defined ($cmd->stop)) {
$self->Verbose("\t running $cmd 's stop \n" , 2 );
eval { $cmd->stop( $kernel, $self, $session ) }
}
}
$kernel->alarm_remove_all();
$kernel->alias_remove( $id[$$self] );
}
=item ControlAddState
POE Event handler that allows new state registrations.
=cut
sub ControlAddState {
my ( $kernel, $self, $command, $coderef, $method ) =
@_[ KERNEL, OBJECT, ARG0, ARG1, ARG2 ];
$kernel->state( $command, $coderef, $method );
}
=item ChangeContext
Poe state that is used the handle all context changes. If a Command needs to
change the context, this is how to do it. The only argument
is a string instructing how to change the context.
'/' changes to root context.
'..' goes back one context
<string> adds <string> to the current context.
No verification is done to see that a reasonable context results from this.
Usually there is no need for a command to directly access change context,
as the Command::Base establish_context state will be able to handle most needs.
lib/Agent/TCLI/Control.pm view on Meta::CPAN
It prefers a response object, but will wrap plain text into a response object
for consistent transport handling.
=cut
sub AsYouWished {
my ($kernel, $sender, $self, $response) =
@_[KERNEL, SENDER, OBJECT, ARG0 ];
# at this point, we should be getting a response object,
# but let's not complain.
if ( ref($response) =~ /Response/ )
{
$self->Verbose( "AsYouWished: Got ".$response->dump(1)." in ".$self->id." \n");
# um I was going to do something here.
}
else # Need to build response
{
$self->Verbose( "AsYouWished: Got '".$response."' in ".$self->id." \n");
my $response = Agent::TCLI::Response->new(
# Don't have request, sending just plain response, hopefully the
# transport knows where it came from based on the sender.
# We really shouldn't be here anyway.
'body' => $response,
'code' => 200,
);
}
# Is this what I want to do? Or should I Respond?
# The Control always acts directly as the interface between Transport
# and control is strictly defined. If we're here, there probably isn't a
# request object to respond to.
$self->Verbose( "AsYouWished: self dump \n",5,$self );
$kernel->post( $self->owner->session->ID => 'PostResponse' => $response, $self );
} #end sub control_AsYouWished
#sub control_err {
# my ($err, $msg) = @_;
# croak("ERROR: $err -> $msg \n");
#}
=item general
A POE event to handle some general commands such as context and status.
It expects a request object parameter.
=cut
sub general {
my ($kernel, $self, $sender, $request,) =
@_[KERNEL, OBJECT, SENDER, ARG0,];
$self->Verbose("general: context(".$self->print_context.")");
my $command = $request->command->[0];
$self->Verbose("general: command(".$command.") args[".
$request->print_args."] input(".$request->input.")", 3);
my $txt;
my $time = localtime($start_time[$$self]);
if ( $command eq 'context')
{
$txt = "Context: ".$self->print_context;
}
elsif ( $command eq 'echo' )
{
$txt = "I heard '".$request->input."' in context ".
$self->print_context." from ".$user[$$self]->get_name();
}
elsif ($command =~ /hi|hello/i)
{
$txt = $command." ".$user[$$self]->get_name().". Tell me what you'd like to do or ask for 'help'. ";
}
elsif ($command eq 'status')
{
$txt .= "This is a ".__PACKAGE__." v".$VERSION."\n";
$txt .= "running inside ".$0.".\n"; # with procecss id ".getppid()."\n";
$txt .= "My IP address is ".$self->local_address.".\n" if defined($self->local_address);
$txt .= "This console was spawned at ".$time.".\n";
foreach my $cmdpkg ( @{ $packages[$$self] } )
{
my $subtxt = "$cmdpkg";
$subtxt =~ s/=.*//;
$txt .= "\tPackage ".$subtxt." is loaded. \n";
}
$txt .= "You are ".$user[$$self]->get_name()." and you have "
.$self->auth()." authorization \n ";
$txt .= "\n";
}
elsif ( $command eq 'Verbose' )
{
if ( $request->args->[0])
{
$self->verbose( $request->args->[0] );
$txt = "Verbose now ".$self->verbose." in context ".
$self->print_context;
}
else
{
$txt = "Verbose: ".$self->verbose;
}
}
elsif ( $command eq 'debug_request' )
{
$txt = "Request dump: ".$request->dump(1);
}
else
{
$txt = "Uh oh, this was not supposed to happen. $command got lost."
}
$self->Verbose("general: txt($txt)",3);
$request->Respond($kernel, $txt);
} #end sub general
=item net
( run in 0.857 second using v1.01-cache-2.11-cpan-39bf76dae61 )