view release on metacpan or  search on metacpan

lib/Agent/TCLI/Control.pm  view on Meta::CPAN

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." ");

lib/Agent/TCLI/Control.pm  view on Meta::CPAN

#							$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;