undef results from the CPAN

undef

Agent-TCLI

view release on metacpan or search on metacpan

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

			$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

#		{
#			$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();

    if ( ref($commands) eq 'ARRAY')

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

			$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

A POE event to execute the net commands. Takes a request object as an ARG0.
The only command it handles currently is I<ip>. This will respond with the
local_address if defined.

=cut

sub net {
    my ($kernel,  $self, $request, ) =
      @_[KERNEL, OBJECT,     ARG0, ];

	my $command = $request->command->[0];
	my ($txt, $code);

    $self->Verbose("net: command($command)");

	if ( $command eq 'ip' )
	{
		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 )

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

#							$var = $self->$attr->{$key}->dump(0);
#							$txt .= Dump($var)."\n";
#							$code = 200;
#						}
#						# 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} ) &&

( run in 1.275 second using v1.01-cache-2.11-cpan-d80b1682f3f )