view release on metacpan or  search on metacpan

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

sub get_name {
  my $self = shift;
  my $id = $id[$$self];
  return ( $self->_set_err( { 'method' => 'get_name',
          'rebuke' => 'name not found in user id'} )
         ) unless ( $id =~ /(\w+)@([-\w]+)/ );
  return ($1);
} # End get_name

=item get_domain()

Retrieve the domain for the user. Currently whatever is after the '@'.

=cut

sub get_domain {
  my $self = shift;
  my $id = $id[$$self];
  return ( $self->_set_err( { 'method' => 'get_domain',
          'rebuke' => 'Domain not found in user id'} )
         ) unless ( $id =~ /(\w+)@([-.\w]+)/ );
  return ($2);
} # End get_domain

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

Returns 0 if user is authorized, 'Not found' if user is not a match, and a message
if a match, but the protocol and/or auth do not match.

Checks id and optional parameters and returns false if matched. This method
will automatically strip off Jabber resource before matching user. It is
usually used as a passthrough while looping through an array/hash of
users in some other object.

It has optional parameters protocol and auth which must be supplied as
regular expression. The default is to use a regexp of any, which means
that the value must be defined in the user in order to match.

By returning false for authorization, one can check the reason why
a true value was returned for unauthorized, or just ignore it.

Usage:

	not_authorized ( { id	   =>  value,        # user id. Will strip off resource
					  protocol =>  qr(jabber),   # optional regex for protocol
					  auth	   =>  qr(master|writer),   # option regex for auth
					} );

=cut

sub not_authorized {
	my $self = shift;

	# Check if incorrect args are sent and set defaults for optionals
	my $args_ref = validate_with ( params => \@_,
		spec   => {
			id        => {     type => &Params::Validate::SCALAR },
			protocol  =>
			{	optional  => 1, default => qr(.*),        # default .* means any, simplifies matching if not set
				callbacks =>
				{ 'is a valid regex' => sub { ref ( $_[0] ) eq 'Regexp' } }
			},
			auth      =>
			{	optional  => 1, default => qr(.*),        # default .* means any, simplifies matching if not set
				callbacks =>
				{ 'is a valid regex' => sub { ref ( $_[0] ) eq 'Regexp' } }
			},
		},
	#	on_fail => sub { $self->_set_err( { 'method' => 'not_authorized',
	#                                       'rebuke' => shift } )
	#	},
	);

	# strip off /.* - jabber resource or something like it if there
	$args_ref->{'id'} =~ s|/.*||;

	# Not using OIO lvalues.
	my $protocol = $protocol[$$self];
	my $auth = $auth[$$self];

	my $txt = '';
	if ( $id[$$self] =~ /$args_ref->{'id'}/i )
	{
		# Match regex to pass. The default of any will pass if not specified.
		if ( $protocol !~ /$args_ref->{'protocol'}/ )
		{
			$txt .= "Improper protocol. $protocol !~ ".$args_ref->{'protocol'}.". \n";
		}
		if ( $auth !~ /$args_ref->{'auth'}/ )
		{
			$txt .= "Inadequate authorization. $auth !~ ".$args_ref->{'auth'}.". \n";
		}
	}
	else
	{
		$txt = "This is not me.";
	}

	$self->Verbose("not_authorized: for ".$args_ref->{'id'}." returning '".$txt."'");
	return $txt;

} # End not_authorized

1;
#__END__
=back

=head3 INHERITED METHODS

This module is an Object::InsideOut object that inherits from Agent::TCLI::Base. It
inherits methods from both. Please refer to their documentation for more
details.

=head1 AUTHOR

Eric Hacker	 E<lt>hacker at cpan.orgE<gt>

=head1 BUGS

SHOULDS and MUSTS are currently not always enforced.

Test scripts not thorough enough.

Probably many others.