view release on metacpan or  search on metacpan

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

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

=cut

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

	my $response_array = thaw($packed_response);
	my %automethod_fields;

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

	my $response = Object::InsideOut->pump( $response_array );

	foreach my $field ( keys %automethod_fields )
	{
		$response->$field( $automethod_fields{$field} );
	}

	$response->verbose($self->verbose);
	$response->do_verbose($self->do_verbose);

	$self->Verbose("UnpackResponse: unpacked ".$response->dump(1),3 );

	return($response);
}

=item authorized ( { parameters (see usage) } )

Checks to see if a id is authorized to use us.

Usage

$self->authorized (
		user@example.com,
		qr(master|writer),  # optional regex for auth
		qr(xmpp),			# optional regex for protocol
		);

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