view release on metacpan or  search on metacpan

lib/Agent/TCLI/Package/Base.pm  view on Meta::CPAN

	$self->Verbose("shutdown:base deleting wheels ",2);
    foreach my $wheel ( keys %{ $wheels[$$self] } )
    {
    	$self->SetWheel($wheel);
    }
    foreach my $control ( keys %{ $controls[$$self] } )
    {
    	$self->SetControl($control);
    }
    # clear all alarms you might have set
    $kernel->alarm_remove_all();

    return ("_shutdown:base ".$self->name )
}

#This POE event handler is called when POE stops a Package.
#The B<_stop> method is :Cumulative within OIO.

sub _stop :Cumulative {
    my ($kernel,  $self,) =
      @_[KERNEL, OBJECT,];

	$self->Verbose("_stop: ".$self->name." stopping");

	return($self->name.":_stop complete ");
}

#Just a placeholder that does nothing but collect unhandled child events
#to keep them out of default.

sub _child {
  my ($kernel,  $self, $session, $id, $error) =
    @_[KERNEL, OBJECT,  SESSION, ARG1, ARG2 ];

   $self->Verbose("child: pid($id) ");
}

=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 is the default show for packages.
It 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 show 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.

One must still define the show Command within one's package to use this. One
must also load the show event handler in the Package's session.

=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);

lib/Agent/TCLI/Package/Base.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);
}

sub GetControl {
	my ($self, $id ) = @_;
	return ( $controls[$$self]->{$id}{'control'} )
		if defined( $controls[$$self]->{$id}{'control'} );
	return (0);
}

sub SetControl {
	my ($self, $control) = @_;
	if ( ref($control) =~ /control/ )
	{
		$controls[$$self]->{$control->id}{'control'} = $control;
	}
	else
	{
		delete ($controls[$$self]->{$control}{'control'} );
		delete ($controls[$$self]->{$control} );
	}
	return
}

sub GetControlKey {
	my ($self, $control, $key) = @_;
	if ( ref($control) =~ /control/ )
	{
		return ( $controls[$$self]->{$control->id}{$key} );
	}
	else
	{
		return ( $controls[$$self]->{$control}{$key} );
	}
}

sub SetControlKey {
	my ($self, $control, $key, $value) = @_;
	$controls[$$self]->{$control->id}{$key} = $value;
	return
}

sub GetWheel {
	my ($self, $id, $sp) = @_;
	return ( $wheels[$$self]->{$id}{'wheel'},
			 $wheels[$$self]->{$id}{'sender'},
			 $wheels[$$self]->{$id}{'postback'} )
		if (defined( $wheels[$$self]->{$id}{'wheel'}) && $sp );

	return ( $wheels[$$self]->{$id}{'wheel'} )
		if ( defined( $wheels[$$self]->{$id}{'wheel'} ) );

	return (0);
}

sub SetWheel {
	my ($self, $wheel) = @_;
	if ( ref($wheel) =~ /POE::Wheel/ )