view release on metacpan or  search on metacpan

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

   $self->Verbose("child: id($id) error($error)") if (defined($error));
}

=item _shutdown

Forcibly shutdown

=cut

sub _shutdown :Cumulative {
    my ($kernel,  $self, $session) =
    @_[KERNEL, OBJECT,  SESSION];
	# TODO, do some proper signal handling
	# especially reconnect on HUP and something on INT

	$self->Verbose('_shutdown: dropping controls',1, $self->controls);

	if ( defined( $self->controls ) )
	{
		foreach my $control ( values %{$self->controls} )
		{
			$kernel->post( $control->id() => '_shutdown' );
			delete(  $self->controls->{ $control->id }  );
		}
	}

	$self->Verbose("_shutdown: removing alarms",1,$kernel->alarm_remove_all() );

    $kernel->alias_remove( $self->alias );

    return("_shutdown ".$self->alias  );
}

sub ControlExecute {
	my ($kernel,  $self, $control, $request ) =
	  @_[KERNEL, OBJECT,     ARG0,     ARG1 ];
	$self->Verbose("ControlExecute: control(".$control->id.") req(".$request->id.") ");

	# Sometimes, control has not started, so we wiat if we have to.
	if ( defined($control->start_time) )
	{
		$kernel->post( $control->id() => 'Execute' => $request );
	}
	else
	{
		$kernel->delay('ControlExecute' => 1 => $control, $request );
	}
}

=item PackRequest

This object method is used by transports to prepare a request for transmssion.

Currently the code is taking a lazy approach and using Perl's YAML and OIO->dump to
safely freeze and thaw the request/responses for Internet transport.
By standardizing these routines in the Base class, more elegant methods
may be transparently enabled in the future.

=cut
# TODO review XEP on this, esp version numbers and best practices.

sub PackRequest {
	my ($self, $request) = @_;
	my $dump = $request->dump();

	# Take out the Base to save space since we're ignore this at the other end.
	delete $dump->[1]{'Agent::TCLI::Base'};

	my $packed_request = freeze($dump);
	return($packed_request);
}

=item PackResponse

This object method is used by transports to prepare a reseponse for transmssion.
See PackRequest for more details.

=cut

sub PackResponse {
	my ($self, $response) = @_;
	my $dump = $response->dump();

	# Take out the Base to save space since we're ignore this at the other end.
	delete $dump->[1]{'Agent::TCLI::Base'};

	# freeze does not terminate the yaml
	my $packed_response = freeze($dump);
	return($packed_response);
}

=item UnpackRequest

This object method is used by transports to unpack a request from transmssion.
See PackRequest for more details.

=cut

sub UnpackRequest {
	my ($self, $packed_request) = @_;
	$self->Verbose("UnpackRequest: $packed_request");

	my $request_array = thaw($packed_request);
	my %automethod_fields;

	foreach my $field ( keys %{ $request_array->[1]{'Agent::TCLI::Request'} } )
	{
		if ( $field =~ s/^get_// )
		{
			my $acc = 'get_'.$field;
			my $mut = 'set_'.$field;
			$automethod_fields{$mut} = $request_array->[1]{'Agent::TCLI::Request'}{ $acc }
				if (defined( $request_array->[1]{'Agent::TCLI::Request'}{ $acc } ));
			delete $request_array->[1]{'Agent::TCLI::Request'}{ $acc };
		}
	}

	my $request = Object::InsideOut->pump( $request_array );

	foreach my $field ( keys %automethod_fields )

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

=cut

sub authorized {
	my ($self, $id, $auth, $protocol) = @_;
	$auth = defined($auth) ? $auth : qr(.*);
	$protocol = defined($protocol) ? $protocol : qr(.*);
	$self->Verbose("authorized: id(".$id.") auth($auth) protocol($protocol)",2);

	# create a blank user as kludge to simply debugging output.
	# This might be a slow memory exhaustion for lots of auth checks
	# if they are not getting cleand up properly
	my $authorized = 	Agent::TCLI::User->new(
			'id'		=> 'no one',
			'protocol'	=> 'none',
			'auth'		=> 'nil',
		);

	# only one should match on id and we get 0 on non id match,
	# so we'll just add through the whole loop of authorized peers
	# and add up the total.

	foreach my $pid ( @{$peers[$$self]} )
	{


		# user not_authorized returns something when not authorized.
	  	my $check = $pid->not_authorized ( {
	  		id	   		=>  $id,
			protocol 	=>  $protocol,
			auth		=>  $auth,
			} );
		$self->Verbose("not_authorized: Checked peer ".$pid->id." got ($check)",3);

	  	if ( !$check  )
	  	{
			# Set authorized to last matched user
			$authorized = $pid;
		}
	} #end foreach peer

	$self->Verbose("authorized:  ".$id." auth check got ".
		$authorized->id()." \n",1);

	return ($authorized)
} # End authorized

=item GetControl( <control_id>, <user>, <user_protocol>, [ <user_auth> ] )

GetControl returns a control object for a control_id / user combination.
It will return either an existing control or create a new one. All
requests for a control are authenticated. Thus when a Transport recieves
a new request, user priviledges are rechecked against the latest database
if GetControl is used to obtain the Control.

The control_id is a unique ID for the transport to use to identify the control.
This is useful in situations where a user may have more than one control
active at a time.
The user must be a Agent::TCLI::User object. The protocol should be one
that the Transport supports and will be matched for authentication.
A transport may optionally override the user_auth level. This would be best
used to drop to a read only transport, but currently the direction is not
enforced.

=cut

sub GetControl {
	my ($self, $control_id, $user, $user_protocol, $user_auth ) = @_;
	$self->Verbose($self->alias.":GetControl: id(".$control_id.") \n");

	my $user_id = ref($user) =~ /User/i ? $user->id : $user;

	my $auth_user = $self->authorized (
	  	$user_id,
	  	qr(.*),
	  	$user_protocol,
	  	);

	return (0) if ( $auth_user->auth eq 'nil' );

	$user_auth = $auth_user->auth unless defined($user_auth);

	if (defined( $controls[$$self]{$control_id} ))   #control in controls hash
	{
	  	$self->Verbose("GetControl: returning existing control for ".$control_id);
	}
	else   # new control
	{
		$controls[$$self]{$control_id} = Agent::TCLI::Control->new({
			'id'		=> $control_id,
			'user'		=> $auth_user,
			'auth'		=> $auth_user->auth(),
			'owner'		=> $self,
        	'verbose'	=> $self->verbose,
        	'do_verbose'=> $self->do_verbose,
        	%{$self->control_options},
    	});

		# This EXAMPLE shows how to set new control attributes.
		# $controls[$$self]{$control_id}->set_option($option);

	    $self->Verbose( "GetControl: New control ".$control_id." on input from ".$auth_user->id." \n",2);
	    $self->Verbose( "GetControl: self dump \n",4,$self);

    } # end if defined control

    return ( $controls[$$self]{$control_id} );

} # End GetControl

=item DeleteControl ( <control_id> )

DeleteControl will remove a reference to Control from the transport.
This does not shutdown the Control's POE session, but will allow
it to stop if there are no other existing references.

=cut

sub DeleteControl {
	my ($self, $control_id ) = @_;
	$self->Verbose($self->alias.":GetControl: id(".$control_id.") \n");