EVOLUTION-MANAGER

Edit File: PLAIN.pm

# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Authen::SASL::Perl::PLAIN;

use strict;
use vars qw($VERSION @ISA);

$VERSION = "2.14";
@ISA	 = qw(Authen::SASL::Perl);

my %secflags = (
	noanonymous => 1,
);

my @tokens = qw(authname user pass);

sub _order { 1 }
sub _secflags {
  shift;
  grep { $secflags{$_} } @_;
}

sub mechanism { 'PLAIN' }

sub client_start {
  my $self = shift;

$self->{error}     = undef;
  $self->{need_step} = 0;

my @parts = map {
    my $v = $self->_call($_);
    defined($v) ? $v : ''
  } @tokens;

join("\0", @parts);
}

sub server_start {
  my $self      = shift;
  my $response  = shift;
  my $user_cb   = shift || sub {};

$self->{error} = undef;
  return $self->set_error("No response: Credentials don't match")
    unless defined $response;

my %parts;
  @parts{@tokens} = split "\0", $response, scalar @tokens;

# I'm not entirely sure of what I am doing
  $self->{answer}{$_} = $parts{$_} for qw/authname user/;
  my $error = "Credentials don't match";

## checkpass
  if (my $checkpass = $self->callback('checkpass')) {
    my $cb = sub {
      my $result = shift;
      unless ($result) {
        $self->set_error($error);
      }
      else {
        $self->set_success;
      }
      $user_cb->();
    };
    $checkpass->($self => { %parts } => $cb );
    return;
  }

## getsecret
  elsif (my $getsecret = $self->callback('getsecret')) {
    my $cb = sub {
      my $good_pass = shift;
      if ($good_pass && $good_pass eq ($parts{pass} || "")) {
        $self->set_success;
      }
      else {
        $self->set_error($error);
      }
      $user_cb->();
    };
    $getsecret->( $self, { map { $_ => $parts{$_ } } qw/user authname/ }, $cb );
    return;
  }

## error by default
  else {
    $self->set_error($error);
    $user_cb->();
  }
}

__END__

=head1 NAME

Authen::SASL::Perl::PLAIN - Plain Login Authentication class

=head1 SYNOPSIS

use Authen::SASL qw(Perl);

$sasl = Authen::SASL->new(
    mechanism => 'PLAIN',
    callback  => {
      user => $user,
      pass => $pass
    },
  );

=head1 DESCRIPTION

This method implements the client and server part of the PLAIN SASL algorithm,
as described in RFC 2595 resp. IETF Draft draft-ietf-sasl-plain-XX.txt

=head2 CALLBACK

The callbacks used are:

=head3 Client

=over 4

=item authname

The authorization id to use after successful authentication (client)

=item user

The username to be used for authentication (client)

=item pass

The user's password to be used for authentication.

=back

=head3 Server

=over4

=item checkpass(username, password, realm)

returns true and false depending on the validity of the credentials passed
in arguments.

=back

=head1 SEE ALSO

L<Authen::SASL>,
L<Authen::SASL::Perl>

=head1 AUTHORS

Software written by Graham Barr <gbarr@pobox.com>,
documentation written by Peter Marschall <peter@adpm.de>.

Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>

=head1 COPYRIGHT

=cut