<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian
# Onions, Nexor and Yann Kerherve.
# All rights reserved. This program is free software; you can redistribute
# it and/or modify it under the same terms as Perl itself.

# See http://www.ietf.org/rfc/rfc2831.txt for details

package Authen::SASL::Perl::DIGEST_MD5;

use strict;
use vars qw($VERSION @ISA $CNONCE $NONCE);
use Digest::MD5 qw(md5_hex md5);
use Digest::HMAC_MD5 qw(hmac_md5);

# TODO: complete qop support in server, should be configurable

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

my %secflags = (
  noplaintext =&gt; 1,
  noanonymous =&gt; 1,
);

# some have to be quoted - some don't - sigh!
my (%cqdval, %sqdval);
@cqdval{qw(
  username authzid realm nonce cnonce digest-uri
)} = ();

## ...and server behaves different than client - double sigh!
@sqdval{keys %cqdval, qw(qop cipher)} = ();
#  username authzid realm nonce cnonce digest-uri qop cipher
#)} = ();

my %multi;
@{$multi{server}}{qw(realm auth-param)} = ();
@{$multi{client}}{qw()} = ();

my @server_required = qw(algorithm nonce);
my @client_required = qw(username nonce cnonce nc qop response);

# available ciphers
my @ourciphers = (
  {
    name  =&gt; 'rc4',
    ssf   =&gt; 128,
    bs    =&gt; 1,
    ks    =&gt; 16,
    pkg   =&gt; 'Crypt::RC4',
    key   =&gt; sub { $_[0] },
    iv    =&gt; sub {},
    fixup =&gt; sub {
      # retrofit the Crypt::RC4 module with standard subs
      *Crypt::RC4::encrypt   = *Crypt::RC4::decrypt =
        sub { goto &amp;Crypt::RC4::RC4; };
      *Crypt::RC4::keysize   =  sub {128};
      *Crypt::RC4::blocksize =  sub {1};
    }
  },
  {
    name  =&gt; '3des',
    ssf   =&gt; 112,
    bs    =&gt; 8,
    ks    =&gt; 16,
    pkg   =&gt; 'Crypt::DES3',
    key   =&gt; sub {
      pack('B8' x 16,
        map { $_ . '0' }
        map { unpack('a7' x 16, $_); }
        unpack('B*', substr($_[0], 0, 14)) );
    },
    iv =&gt; sub { substr($_[0], -8, 8) },
  },
  {
    name  =&gt; 'des',
    ssf   =&gt; 56,
    bs    =&gt; 8,
    ks    =&gt; 16,
    pkg   =&gt; 'Crypt::DES',
    key   =&gt; sub {
      pack('B8' x 8,
        map { $_ . '0' }
        map { unpack('a7' x 8, $_); }
        unpack('B*',substr($_[0], 0, 7)) );
    },
    iv =&gt; sub { substr($_[0], -8, 8) },
  },
  {
    name  =&gt; 'rc4-56',
    ssf   =&gt; 56,
    bs    =&gt; 1,
    ks    =&gt; 7,
    pkg   =&gt; 'Crypt::RC4',
    key   =&gt; sub { $_[0] },
    iv    =&gt; sub {},
    fixup =&gt; sub {
      *Crypt::RC4::encrypt   = *Crypt::RC4::decrypt =
        sub { goto &amp;Crypt::RC4::RC4; };
      *Crypt::RC4::keysize   =  sub {56};
      *Crypt::RC4::blocksize =  sub {1};
    }
  },
  {
    name  =&gt; 'rc4-40',
    ssf   =&gt; 40,
    bs    =&gt; 1,
    ks    =&gt; 5,
    pkg   =&gt; 'Crypt::RC4',
    key   =&gt; sub { $_[0] },
    iv    =&gt; sub {},
    fixup =&gt; sub {
      *Crypt::RC4::encrypt   = *Crypt::RC4::decrypt =
        sub { goto &amp;Crypt::RC4::RC4; };
      *Crypt::RC4::keysize   =  sub {40};
      *Crypt::RC4::blocksize =  sub {1};
    }
  },
);

## The system we are on, might not be able to crypt the stream
our $NO_CRYPT_AVAILABLE = 1;
for (@ourciphers) {
    eval "require $_-&gt;{pkg}";
    unless ($@) {
        $NO_CRYPT_AVAILABLE = 0;
        last;
    }
}

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

sub mechanism { 'DIGEST-MD5' }

sub _init {
  my ($pkg, $self) = @_;
  bless $self, $pkg;

  # set default security properties
  $self-&gt;property('minssf',      0);
  $self-&gt;property('maxssf',      int 2**31 - 1);    # XXX - arbitrary "high" value
  $self-&gt;property('maxbuf',      0xFFFFFF);         # maximum supported by GSSAPI mech
  $self-&gt;property('externalssf', 0);

  $self;
}

sub _init_server {
  my $server  = shift;
  my $options = shift || {};
  if (!ref $options or ref $options ne 'HASH') {
    warn "options for DIGEST_MD5 should be a hashref";
    $options = {};
  }

  ## new server, means new nonce_counts
  $server-&gt;{nonce_counts} = {};

  ## determine supported qop
  my   @qop = ('auth');
  push @qop, 'auth-int'  unless $options-&gt;{no_integrity};
  push @qop, 'auth-conf' unless $options-&gt;{no_integrity}
                             or $options-&gt;{no_confidentiality}
                             or $NO_CRYPT_AVAILABLE;

  $server-&gt;{supported_qop} = { map { $_ =&gt; 1 } @qop };
}

sub init_sec_layer {
  my $self           = shift;
  $self-&gt;{cipher}    = undef;
  $self-&gt;{khc}       = undef;
  $self-&gt;{khs}       = undef;
  $self-&gt;{sndseqnum} = 0;
  $self-&gt;{rcvseqnum} = 0;

  # reset properties for new session
  $self-&gt;property(maxout =&gt; undef);
  $self-&gt;property(ssf    =&gt; undef);
}

# no initial value passed to the server
sub client_start {
  my $self = shift;

  $self-&gt;{need_step} = 1;
  $self-&gt;{error}     = undef;
  $self-&gt;{state}     = 0;
  $self-&gt;init_sec_layer;
  '';
}

sub server_start {
  my $self       = shift;
  my $challenge  = shift;
  my $cb         = shift || sub {};

  $self-&gt;{need_step} = 1;
  $self-&gt;{error}     = undef;
  $self-&gt;{nonce}     = md5_hex($NONCE || join (":", $$, time, rand));

  $self-&gt;init_sec_layer;

  my $qop = [ sort keys %{$self-&gt;{supported_qop}} ];

  ## get the realm using callbacks but default to the host specified
  ## during the instanciation of the SASL object
  my $realm = $self-&gt;_call('realm');
  $realm  ||= $self-&gt;host;

  my %response = (
    nonce         =&gt; $self-&gt;{nonce},
    charset       =&gt; 'utf-8',
    algorithm     =&gt; 'md5-sess',
    realm         =&gt; $realm,
    maxbuf        =&gt; $self-&gt;property('maxbuf'),

## IN DRAFT ONLY:
# If this directive is present multiple times the client MUST treat
# it as if it received a single qop directive containing a comma
# separated value from all instances. I.e.,
# 'qop="auth",qop="auth-int"' is the same as 'qop="auth,auth-int"

    'qop'         =&gt; $qop,
    'cipher'      =&gt; [ map { $_-&gt;{name} } @ourciphers ],
  );
  my $final_response = _response(\%response);
  $cb-&gt;($final_response);
  return;
}

sub client_step {   # $self, $server_sasl_credentials
  my ($self, $challenge) = @_;
  $self-&gt;{server_params} = \my %sparams;

  # Parse response parameters
  $self-&gt;_parse_challenge(\$challenge, server =&gt; $self-&gt;{server_params})
    or return $self-&gt;set_error("Bad challenge: '$challenge'");

  if ($self-&gt;{state} == 1) {
    # check server's `rspauth' response
    return $self-&gt;set_error("Server did not send rspauth in step 2")
      unless ($sparams{rspauth});
    return $self-&gt;set_error("Invalid rspauth in step 2")
      unless ($self-&gt;{rspauth} eq $sparams{rspauth});

    # all is well
    $self-&gt;set_success;
    return '';
  }

  # check required fields in server challenge
  if (my @missing = grep { !exists $sparams{$_} } @server_required) {
    return $self-&gt;set_error("Server did not provide required field(s): @missing")
  }

  my %response = (
    nonce        =&gt; $sparams{'nonce'},
    cnonce       =&gt; md5_hex($CNONCE || join (":", $$, time, rand)),
    'digest-uri' =&gt; $self-&gt;service . '/' . $self-&gt;host,
    # calc how often the server nonce has been seen; server expects "00000001"
    nc           =&gt; sprintf("%08d",     ++$self-&gt;{nonce_counts}{$sparams{'nonce'}}),
    charset      =&gt; $sparams{'charset'},
  );

  return $self-&gt;set_error("Server qop too weak (qop = $sparams{'qop'})")
    unless ($self-&gt;_client_layer(\%sparams,\%response));

  # let caller-provided fields override defaults: authorization ID, service name, realm

  my $s_realm = $sparams{realm} || [];
  my $realm = $self-&gt;_call('realm', @$s_realm);
  unless (defined $realm) {
    # If the user does not pick a realm, use the first from the server
    $realm = $s_realm-&gt;[0];
  }
  if (defined $realm) {
    $response{realm} = $realm;
  }

  my $authzid = $self-&gt;_call('authname');
  if (defined $authzid) {
    $response{authzid} = $authzid;
  }

  my $serv_name = $self-&gt;_call('serv');
  if (defined $serv_name) {
    $response{'digest-uri'} .= '/' . $serv_name;
  }

  my $user = $self-&gt;_call('user');
  return $self-&gt;set_error("Username is required")
    unless defined $user;
  $response{username} = $user;

  my $password = $self-&gt;_call('pass');
  return $self-&gt;set_error("Password is required")
    unless defined $password;

  $self-&gt;property('maxout', $sparams{maxbuf} || 65536);

  # Generate the response value
  $self-&gt;{state} = 1;

  my ($response, $rspauth)
    = $self-&gt;_compute_digests_and_set_keys($password, \%response);

  $response{response} = $response;
  $self-&gt;{rspauth}    = $rspauth;

  # finally, return our response token
  return _response(\%response, "is_client");
}

sub _compute_digests_and_set_keys {
  my $self     = shift;
  my $password = shift;
  my $params   = shift;

  if (defined $params-&gt;{realm} and ref $params-&gt;{realm} eq 'ARRAY') {
    $params-&gt;{realm} = $params-&gt;{realm}[0];
  }

  my $realm = $params-&gt;{realm};
  $realm = "" unless defined $realm;

  my $A1 = join (":",
    md5(join (":", $params-&gt;{username}, $realm, $password)),
    @$params{defined($params-&gt;{authzid})
      ? qw(nonce cnonce authzid)
      : qw(nonce cnonce)
    }
  );

  # pre-compute MD5(A1) and HEX(MD5(A1)); these are used multiple times below
  my $hdA1 = unpack("H*", (my $dA1 = md5($A1)) );

  # derive keys for layer encryption / integrity
  $self-&gt;{kic} = md5($dA1,
    'Digest session key to client-to-server signing key magic constant');

  $self-&gt;{kis} = md5($dA1,
    'Digest session key to server-to-client signing key magic constant');

  if (my $cipher = $self-&gt;{cipher}) {
    &amp;{ $cipher-&gt;{fixup} || sub{} };

    # compute keys for encryption
    my $ks = $cipher-&gt;{ks};
    $self-&gt;{kcc} = md5(substr($dA1,0,$ks),
      'Digest H(A1) to client-to-server sealing key magic constant');
    $self-&gt;{kcs} = md5(substr($dA1,0,$ks),
      'Digest H(A1) to server-to-client sealing key magic constant');

    # get an encryption and decryption handle for the chosen cipher
    $self-&gt;{khc} = $cipher-&gt;{pkg}-&gt;new($cipher-&gt;{key}-&gt;($self-&gt;{kcc}));
    $self-&gt;{khs} = $cipher-&gt;{pkg}-&gt;new($cipher-&gt;{key}-&gt;($self-&gt;{kcs}));

    # initialize IVs
    $self-&gt;{ivc} = $cipher-&gt;{iv}-&gt;($self-&gt;{kcc});
    $self-&gt;{ivs} = $cipher-&gt;{iv}-&gt;($self-&gt;{kcs});
  }

  my $A2 = "AUTHENTICATE:" . $params-&gt;{'digest-uri'};
  $A2 .= ":00000000000000000000000000000000" if ($params-&gt;{qop} ne 'auth');

  my $response = md5_hex(
    join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2))
  );

  # calculate server `rspauth' response, so we can check in step 2
  # the only difference here is in the A2 string which from which
  # `AUTHENTICATE' is omitted in the calculation of `rspauth'
  $A2 = ":" . $params-&gt;{'digest-uri'};
  $A2 .= ":00000000000000000000000000000000" if ($params-&gt;{qop} ne 'auth');

  my $rspauth = md5_hex(
    join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2))
  );

  return ($response, $rspauth);
}

sub server_step {
  my $self      = shift;
  my $challenge = shift;
  my $cb        = shift || sub {};

  $self-&gt;{client_params} = \my %cparams;
  unless ( $self-&gt;_parse_challenge(\$challenge, client =&gt; $self-&gt;{client_params}) ) {
   $self-&gt;set_error("Bad challenge: '$challenge'");
   return $cb-&gt;();
  }

  # check required fields in server challenge
  if (my @missing = grep { !exists $cparams{$_} } @client_required) {
    $self-&gt;set_error("Client did not provide required field(s): @missing");
    return $cb-&gt;();
  }

  my $count = hex ($cparams{'nc'} || 0);
  unless ($count == ++$self-&gt;{nonce_counts}{$cparams{nonce}}) {
    $self-&gt;set_error("nonce-count doesn't match: $count");
    return $cb-&gt;();
  }

  my $qop = $cparams{'qop'} || "auth";
  unless ($self-&gt;is_qop_supported($qop)) {
    $self-&gt;set_error("Client qop not supported (qop = '$qop')");
    return $cb-&gt;();
  }

  my $username = $cparams{'username'};
  unless ($username) {
    $self-&gt;set_error("Client didn't provide a username");
    return $cb-&gt;();
  }

  # "The authzid MUST NOT be an empty string."
  if (exists $cparams{authzid} &amp;&amp; $cparams{authzid} eq '') {
      $self-&gt;set_error("authzid cannot be empty");
      return $cb-&gt;();
  }
  my $authzid = $cparams{authzid};

  # digest-uri: "Servers SHOULD check that the supplied value is correct.
  # This will detect accidental connection to the incorrect server, as well as
  # some redirection attacks"
  my $digest_uri = $cparams{'digest-uri'};
  my ($cservice, $chost, $cservname) = split '/', $digest_uri, 3;
  if ($cservice ne $self-&gt;service or $chost ne $self-&gt;host) {
      # XXX deal with serv_name
      $self-&gt;set_error("Incorrect digest-uri");
      return $cb-&gt;(); 
  }

  unless (defined $self-&gt;callback('getsecret')) {
    $self-&gt;set_error("a getsecret callback MUST be defined");
    $cb-&gt;();
    return;
  }

  my $realm = $self-&gt;{client_params}-&gt;{'realm'};
  my $response_check = sub {
    my $password = shift;
    return $self-&gt;set_error("Cannot get the passord for $username") 
        unless defined $password;
 
    ## configure the security layer
    $self-&gt;_server_layer($qop)
        or return $self-&gt;set_error("Cannot negociate the security layer");
 
    my ($expected, $rspauth)
        = $self-&gt;_compute_digests_and_set_keys($password, $self-&gt;{client_params});
 
    return $self-&gt;set_error("Incorrect response $self-&gt;{client_params}-&gt;{response} &lt;&gt; $expected")
        unless $expected eq $self-&gt;{client_params}-&gt;{response};
 
    my %response = (
        rspauth =&gt; $rspauth,
    );
 
    # I'm not entirely sure of what I am doing
    $self-&gt;{answer}{$_} = $self-&gt;{client_params}-&gt;{$_} for qw/username authzid realm serv/;
 
    $self-&gt;set_success;
    return _response(\%response);
  };

  $self-&gt;callback('getsecret')-&gt;(
    $self,
    { user =&gt; $username, realm =&gt; $realm, authzid =&gt; $authzid },
    sub { $cb-&gt;( $response_check-&gt;( shift ) ) },
  );
}

sub is_qop_supported {
    my $self = shift;
    my $qop  = shift;
    return $self-&gt;{supported_qop}{$qop};
}

sub _response {
  my $response  = shift;
  my $is_client = shift;

  my @out;
  for my $k (sort keys %$response) {
    my $is_array = ref $response-&gt;{$k} &amp;&amp; ref $response-&gt;{$k} eq 'ARRAY';
    my @values = $is_array ? @{$response-&gt;{$k}} : ($response-&gt;{$k});
    # Per spec, one way of doing it: multiple k=v
    #push @out, [$k, $_] for @values;
    # other way: comma separated list
    push @out, [$k, join (',', @values)];
  }
  return join (",", map { _qdval($_-&gt;[0], $_-&gt;[1], $is_client) } @out);
}

sub _parse_challenge {
  my $self          = shift;
  my $challenge_ref = shift;
  my $type          = shift;
  my $params        = shift;

  while($$challenge_ref =~
           s/^(?:\s*,)*\s*            # remaining or crap
             ([\w-]+)                 # key, eg: qop
             =
             ("([^\\"]+|\\.)*"|[^,]+) # value, eg: auth-conf or "NoNcE"
             \s*(?:,\s*)*             # remaining
           //x) {

    my ($k, $v) = ($1,$2);
    if ($v =~ /^"(.*)"$/s) {
      ($v = $1) =~ s/\\(.)/$1/g;
    }
    if (exists $multi{$type}{$k}) {
      my $aref = $params-&gt;{$k} ||= [];
      push @$aref, $v;
    }
    elsif (defined $params-&gt;{$k}) {
      return $self-&gt;set_error("Bad challenge: '$$challenge_ref'");
    }
    else {
      $params-&gt;{$k} = $v;
    }
  }
  return length $$challenge_ref ? 0 : 1;
}

sub _qdval {
  my ($k, $v, $is_client) = @_;

  my $qdval = $is_client ? \%cqdval : \%sqdval;

  if (!defined $v) {
    return;
  }
  elsif (exists $qdval-&gt;{$k}) {
    $v =~ s/([\\"])/\\$1/g;
    return qq{$k="$v"};
  }

  return "$k=$v";
}

sub _server_layer {
  my ($self, $auth) = @_;

  # XXX dupe
  # construct our qop mask
  my $maxssf = $self-&gt;property('maxssf') - $self-&gt;property('externalssf');
  $maxssf = 0 if ($maxssf &lt; 0);
  my $minssf = $self-&gt;property('minssf') - $self-&gt;property('externalssf');
  $minssf = 0 if ($minssf &lt; 0);

  return undef if ($maxssf &lt; $minssf); # sanity check

  my $ciphers = [ map { $_-&gt;{name} } @ourciphers ];
  if ((     $auth eq 'auth-conf')
        and $self-&gt;_select_cipher($minssf, $maxssf, $ciphers )) {
    $self-&gt;property('ssf', $self-&gt;{cipher}-&gt;{ssf});
    return 1;
  }
  if ($auth eq 'auth-int') {
    $self-&gt;property('ssf', 1);
    return 1;
  }
  if ($auth eq 'auth') {
    $self-&gt;property('ssf', 0);
    return 1;
  }

  return undef;
}

sub _client_layer {
  my ($self, $sparams, $response) = @_;

  # construct server qop mask
  # qop in server challenge is optional: if not there "auth" is assumed
  my $smask = 0;
  map {
    m/^auth$/      and $smask |= 1;
    m/^auth-int$/  and $smask |= 2;
    m/^auth-conf$/ and $smask |= 4;
  } split(/,/, $sparams-&gt;{qop}||'auth'); # XXX I think we might have a bug here bc. of LWS

  # construct our qop mask
  my $cmask = 0;
  my $maxssf = $self-&gt;property('maxssf') - $self-&gt;property('externalssf');
  $maxssf = 0 if ($maxssf &lt; 0);
  my $minssf = $self-&gt;property('minssf') - $self-&gt;property('externalssf');
  $minssf = 0 if ($minssf &lt; 0);

  return undef if ($maxssf &lt; $minssf); # sanity check

  # ssf values &gt; 1 mean integrity and confidentiality 
  # ssf == 1 means integrity but no confidentiality
  # ssf &lt; 1 means neither integrity nor confidentiality
  # no security layer can be had if buffer size is 0
  $cmask |= 1 if ($minssf &lt; 1);
  $cmask |= 2 if ($minssf &lt;= 1 and $maxssf &gt;= 1);
  $cmask |= 4 if ($maxssf &gt; 1);

  # find common bits
  $cmask &amp;= $smask;

  # parse server cipher options
  my @sciphers = split(/,/, $sparams-&gt;{'cipher-opts'}||$sparams-&gt;{cipher}||'');

  if (($cmask &amp; 4) and $self-&gt;_select_cipher($minssf,$maxssf,\@sciphers)) {
    $response-&gt;{qop} = 'auth-conf';
    $response-&gt;{cipher} = $self-&gt;{cipher}-&gt;{name};
    $self-&gt;property('ssf', $self-&gt;{cipher}-&gt;{ssf});
    return 1;
  }
  if ($cmask &amp; 2) {
    $response-&gt;{qop} = 'auth-int';
    $self-&gt;property('ssf', 1);
    return 1;
  }
  if ($cmask &amp; 1) {
    $response-&gt;{qop} = 'auth';
    $self-&gt;property('ssf', 0);
    return 1;
  }

  return undef;
}

sub _select_cipher {
  my ($self, $minssf, $maxssf, $ciphers) = @_;

  # compose a subset of candidate ciphers based on ssf and peer list
  my @a = map {
    my $c = $_;
    (grep { $c-&gt;{name} eq $_ } @$ciphers and
      $c-&gt;{ssf} &gt;= $minssf and $c-&gt;{ssf} &lt;= $maxssf) ? $_ : ()
  } @ourciphers;

  # from these, select the first one we can create an instance of
  for (@a) {
    next unless eval "require $_-&gt;{pkg}";
    $self-&gt;{cipher} = $_;
    return 1;
  }

  return 0;
}

use Digest::HMAC_MD5 qw(hmac_md5);

sub encode {  # input: self, plaintext buffer,length (length not used here)
  my $self   = shift;
  my $seqnum = pack('N', $self-&gt;{sndseqnum}++);
  my $mac    = substr(hmac_md5($seqnum . $_[0], $self-&gt;{kic}), 0, 10);

  # if integrity only, return concatenation of buffer, MAC, TYPE and SEQNUM
  return $_[0] . $mac.pack('n',1) . $seqnum unless ($self-&gt;{khc});

  # must encrypt, block ciphers need padding bytes
  my $pad = '';
  my $bs = $self-&gt;{cipher}-&gt;{bs};
  if ($bs &gt; 1) {
    # padding is added in between BUF and MAC
    my $n = $bs - ((length($_[0]) + 10) &amp; ($bs - 1));
    $pad = chr($n) x $n;
  }

  # XXX - for future AES cipher support, the currently used common _crypt()
  # function probably wont do; we might to switch to per-cipher routines
  # like so:
  #  return $self-&gt;{khc}-&gt;encrypt($_[0] . $pad . $mac) . pack('n', 1) . $seqnum;
  return $self-&gt;_crypt(0, $_[0] . $pad . $mac) . pack('n', 1) . $seqnum;
}

sub decode {  # input: self, cipher buffer,length
  my ($self, $buf, $len) = @_;

  return if ($len &lt;= 16);

  # extract TYPE/SEQNUM from end of buffer
  my ($type,$seqnum) = unpack('na[4]', substr($buf, -6, 6, ''));

  # decrypt remaining buffer, if necessary
  if ($self-&gt;{khs}) {
    # XXX - see remark above in encode() #$buf = $self-&gt;{khs}-&gt;decrypt($buf);
    $buf = $self-&gt;_crypt(1, $buf);
  }
  return unless ($buf);

  # extract 10-byte MAC from the end of (decrypted) buffer
  my ($mac) = unpack('a[10]', substr($buf, -10, 10, ''));

  if ($self-&gt;{khs} and $self-&gt;{cipher}-&gt;{bs} &gt; 1) {
    # remove padding
    my $n = ord(substr($buf, -1, 1));
    substr($buf, -$n, $n, '');
  }

  # check the MAC
  my $check = substr(hmac_md5($seqnum . $buf, $self-&gt;{kis}), 0, 10);
  return if ($mac ne $check);
  return if (unpack('N', $seqnum) != $self-&gt;{rcvseqnum});
  $self-&gt;{rcvseqnum}++;

  return $buf;
}

sub _crypt {  # input: op(decrypting=1/encrypting=0)), buffer
  my ($self,$d) = (shift,shift);
  my $bs = $self-&gt;{cipher}-&gt;{bs};

  if ($bs &lt;= 1) {
    # stream cipher
    return $d ? $self-&gt;{khs}-&gt;decrypt($_[0]) : $self-&gt;{khc}-&gt;encrypt($_[0])
  }

  # the remainder of this sub is for block ciphers

  # get current IV
  my $piv = \$self-&gt;{$d ? 'ivs' : 'ivc'};
  my $iv = $$piv;

  my $result = join '', map {
    my $x = $d
      ? $iv ^ $self-&gt;{khs}-&gt;decrypt($_)
      : $self-&gt;{khc}-&gt;encrypt($iv ^ $_);
    $iv = $d ? $_ : $x;
    $x;
  } unpack("a$bs "x(int(length($_[0])/$bs)), $_[0]);

  # store current IV
  $$piv = $iv;
  return $result;
}

1;

__END__

=head1 NAME

Authen::SASL::Perl::DIGEST_MD5 - Digest MD5 Authentication class

=head1 SYNOPSIS

  use Authen::SASL qw(Perl);

  $sasl = Authen::SASL-&gt;new(
    mechanism =&gt; 'DIGEST-MD5',
    callback  =&gt; {
      user =&gt; $user, 
      pass =&gt; $pass,
      serv =&gt; $serv
    },
  );

=head1 DESCRIPTION

This method implements the client and server parts of the DIGEST-MD5 SASL
algorithm, as described in RFC 2831.

=head2 CALLBACK

The callbacks used are:

=head3 client

=over 4

=item authname

The authorization id to use after successful authentication

=item user

The username to be used in the response

=item pass

The password to be used to compute the response.

=item serv

The service name when authenticating to a replicated service

=item realm

The authentication realm when overriding the server-provided default.
If not given the server-provided value is used.

The callback will be passed the list of realms that the server provided
in the initial response.

=back

=head3 server

=over 4

=item realm

The default realm to provide to the client

=item getsecret(username, realm, authzid)

returns the password associated with C&lt;username&gt; and C&lt;realm&gt;

=back

=head2 PROPERTIES

The properties used are:

=over 4

=item maxbuf

The maximum buffer size for receiving cipher text

=item minssf

The minimum SSF value that should be provided by the SASL security layer.
The default is 0

=item maxssf

The maximum SSF value that should be provided by the SASL security layer.
The default is 2**31

=item externalssf

The SSF value provided by an underlying external security layer.
The default is 0

=item ssf

The actual SSF value provided by the SASL security layer after the SASL
authentication phase has been completed. This value is read-only and set
by the implementation after the SASL authentication phase has been completed.

=item maxout

The maximum plaintext buffer size for sending data to the peer.
This value is set by the implementation after the SASL authentication
phase has been completed and a SASL security layer is in effect.

=back


=head1 SEE ALSO

L&lt;Authen::SASL&gt;,
L&lt;Authen::SASL::Perl&gt;

=head1 AUTHORS

Graham Barr, Djamel Boudjerda (NEXOR), Paul Connolly, Julian Onions (NEXOR),
Yann Kerherve.

Please report any bugs, or post any suggestions, to the perl-ldap mailing list
&lt;perl-ldap@perl.org&gt;

=head1 COPYRIGHT 

Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly,
Julian Onions, Nexor, Peter Marschall and Yann Kerherve.
All rights reserved. This program is free software; you can redistribute 
it and/or modify it under the same terms as Perl itself.

=cut
</pre></body></html>