<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># Copyright (c) 2002 Graham Barr &lt;gbarr@pobox.com&gt;. 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;
$Authen::SASL::Perl::VERSION = '2.1700';
use strict;
use warnings;
use Carp;


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

sub server_new {
  my ($pkg, $parent, $service, $host, $options) = @_;

  my $self = {
    callback  =&gt; { %{$parent-&gt;callback} },
    service   =&gt; $service  || '',
    host      =&gt; $host     || '',
    debug     =&gt; $parent-&gt;{debug} || 0,
    need_step =&gt; 1,
  };

  my $mechanism = $parent-&gt;mechanism
    or croak "No server mechanism specified";
  $mechanism =~ s/^\s*\b(.*)\b\s*$/$1/g;
  $mechanism =~ s/-/_/g;
  $mechanism =  uc $mechanism;
  my $mpkg   = __PACKAGE__ . "::$mechanism";
  eval "require $mpkg;"
    or croak "Cannot use $mpkg for " . $parent-&gt;mechanism;
  my $server = $mpkg-&gt;_init($self);
  $server-&gt;_init_server($options);
  return $server;
}

sub client_new {
  my ($pkg, $parent, $service, $host, $secflags) = @_;

  my @sec = grep { $secflags{$_} } split /\W+/, lc($secflags || '');

  my $self = {
    callback  =&gt; { %{$parent-&gt;callback} },
    service   =&gt; $service  || '',
    host      =&gt; $host     || '',
    debug     =&gt; $parent-&gt;{debug} || 0,
    need_step =&gt; 1,
  };

  my @mpkg = sort {
    $b-&gt;_order &lt;=&gt; $a-&gt;_order
  } grep {
    my $have = $have{$_} ||= (eval "require $_;" and $_-&gt;can('_secflags')) ? 1 : -1;
    $have &gt; 0 and $_-&gt;_secflags(@sec) == @sec
  } map {
    (my $mpkg = __PACKAGE__ . "::$_") =~ s/-/_/g;
    $mpkg;
  } split /[^-\w]+/, $parent-&gt;mechanism
    or croak "No SASL mechanism found\n";

  $mpkg[0]-&gt;_init($self);
}

sub _init_server {}

sub _order   { 0 }
sub code     { defined(shift-&gt;{error}) || 0 }
sub error    { shift-&gt;{error}    }
sub service  { shift-&gt;{service}  }
sub host     { shift-&gt;{host}     }

sub need_step {
    my $self = shift;
    return 0 if $self-&gt;{error};
    return $self-&gt;{need_step};
}

## I think I need to rename that to end()?
## It doesn't mean that SASL is successful, but that
## that the negotiation is over, no more step necessary
## at least for the client
sub set_success {
    my $self = shift;
    $self-&gt;{need_step} = 0;
}

sub is_success {
    my $self = shift;
    return !$self-&gt;code &amp;&amp; !$self-&gt;need_step;
}

sub set_error {
  my $self = shift;
  $self-&gt;{error} = shift;
  return;
}

# set/get property
sub property {
  my $self = shift;
  my $prop = $self-&gt;{property} ||= {};
  return $prop-&gt;{ $_[0] } if @_ == 1;
  my %new = @_;
  @{$prop}{keys %new} = values %new;
  1;
}

sub callback {
  my $self = shift;

  return $self-&gt;{callback}{$_[0]} if @_ == 1;

  my %new = @_;
  @{$self-&gt;{callback}}{keys %new} = values %new;

  $self-&gt;{callback};
}

# Should be defined in the mechanism sub-class
sub mechanism    { undef }
sub client_step  { undef }
sub client_start { undef }
sub server_step  { undef }
sub server_start { undef }

# Private methods used by Authen::SASL::Perl that
# may be overridden in mechanism sub-classes

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

  bless $href, $pkg;
}

sub _call {
  my ($self, $name) = splice(@_,0,2);

  my $cb = $self-&gt;{callback}{$name};

  return undef unless defined $cb;

  my $value;

  if (ref($cb) eq 'ARRAY') {
    my @args = @$cb;
    $cb = shift @args;
    $value = $cb-&gt;($self, @args);
  }
  elsif (ref($cb) eq 'CODE') {
    $value = $cb-&gt;($self, @_);
  }
  else {
    $value = $cb;
  }

  $self-&gt;{answer}{$name} = $value
    unless $name eq 'pass'; # Do not store password

  return $value;
}

# TODO: Need a better name than this
sub answer {
  my ($self, $name) = @_;
  $self-&gt;{answer}{$name};
}

sub _secflags { 0 }

sub securesocket {
  my $self = shift;
  return $_[0] unless (defined($self-&gt;property('ssf')) &amp;&amp; $self-&gt;property('ssf') &gt; 0);

  local *GLOB; # avoid used only once warning
  my $glob = \do { local *GLOB; };
  tie(*$glob, 'Authen::SASL::Perl::Layer', $_[0], $self);
  $glob;
}

{

#
# Add SASL encoding/decoding to a filehandle
#

  package # private package; prevent detection by MetaCPAN
      Authen::SASL::Perl::Layer;

  use bytes;

  require Tie::Handle;
  our @ISA = qw(Tie::Handle);

  sub TIEHANDLE {
    my ($class, $fh, $conn) = @_;
    my $self;

    warn __PACKAGE__ . ': non-blocking handle may not work'
      if ($fh-&gt;can('blocking') and not $fh-&gt;blocking());

    $self-&gt;{fh}         = $fh;
    $self-&gt;{conn}       = $conn;
    $self-&gt;{readbuflen} = 0;
    $self-&gt;{sndbufsz}   = $conn-&gt;property('maxout');
    $self-&gt;{rcvbufsz}   = $conn-&gt;property('maxbuf');

    return bless($self, $class);
  }

  sub CLOSE {
    my ($self) = @_;

    # forward close to the inner handle
    close($self-&gt;{fh});
    delete $self-&gt;{fh};
  }

  sub DESTROY {
    my ($self) = @_;
    delete $self-&gt;{fh};
    undef $self;
  }

  sub FETCH {
    my ($self) = @_;
    return $self-&gt;{fh};
  }

  sub FILENO {
    my ($self) = @_;
    return fileno($self-&gt;{fh});
  }


  sub READ {
    my ($self, $buf, $len, $offset) = @_;
    my $debug = $self-&gt;{conn}-&gt;{debug};

    $buf = \$_[1];

    my $avail = $self-&gt;{readbuflen};

    print STDERR " [READ(len=$len,offset=$offset)] avail=$avail;\n"
      if ($debug &amp; 4);

    # Check if there's leftovers from a previous READ
    if ($avail &lt;= 0) {
      $avail = $self-&gt;_getbuf();
      return undef unless ($avail &gt; 0);
    }

    # if there's more than we need right now, leave the rest for later
    if ($avail &gt;= $len) {
      print STDERR "   GOT ALL: avail=$avail; need=$len\n"
        if ($debug &amp; 4);
      substr($$buf, $offset, $len) = substr($self-&gt;{readbuf}, 0, $len, '');
      $self-&gt;{readbuflen} -= $len;
      return ($len);
    }

    # there's not enough; take all we have, read more on next call
    print STDERR "   GOT PARTIAL: avail=$avail; need=$len\n"
      if ($debug &amp; 4);
    substr($$buf, $offset || 0, $avail) = $self-&gt;{readbuf};
    $self-&gt;{readbuf}    = '';
    $self-&gt;{readbuflen} = 0;

    return ($avail);
  }

  # retrieve and decode a buffer of cipher text in SASL format
  sub _getbuf {
    my ($self) = @_;
    my $debug  = $self-&gt;{conn}-&gt;{debug};
    my $fh     = $self-&gt;{fh};
    my $buf    = '';

    # first, read 4-octet buffer size
    my $n = 0;
    while ($n &lt; 4) {
      my $rv = sysread($fh, $buf, 4 - $n, $n);
      print STDERR "    [getbuf: sysread($fh,$buf,4-$n,$n)=$rv: $!\n"
        if ($debug &amp; 4);
      return $rv unless $rv &gt; 0;
      $n += $rv;
    }

    # size is encoded in network byte order
    my ($bsz) = unpack('N', $buf);
    print STDERR "    [getbuf: cipher buffer sz=$bsz]\n" if ($debug &amp; 4);
    return undef unless ($bsz &lt;= $self-&gt;{rcvbufsz});

    # next, read actual cipher text
    $buf = '';
    $n   = 0;
    while ($n &lt; $bsz) {
      my $rv = sysread($fh, $buf, $bsz - $n, $n);
      print STDERR "    [getbuf: got o=$n,n=", $bsz - $n, ",rv=$rv,bl=" . length($buf) . "]\n"
        if ($debug &amp; 4);
      return $rv unless $rv &gt; 0;
      $n += $rv;
    }

    # call mechanism specific decoding routine
    $self-&gt;{readbuf} = $self-&gt;{conn}-&gt;decode($buf, $bsz);
    $n = length($self-&gt;{readbuf});
    print STDERR "    [getbuf: clear text buffer sz=$n]\n" if ($debug &amp; 4);
    $self-&gt;{readbuflen} = $n;
  }


  # Encrypting a write() to a filehandle is much easier than reading, because
  # all the data to be encrypted is immediately available
  sub WRITE {
    my ($self, $data, $len, $offset) = @_;
    my $debug = $self-&gt;{conn}-&gt;{debug};

    my $fh = $self-&gt;{fh};
    $len = length($data) if $len &gt; length($data); # RT 85294

    # put on wire in peer-sized chunks
    my $bsz = $self-&gt;{sndbufsz};
    while ($len &gt; 0) {
      print STDERR " [WRITE: chunk $bsz/$len]\n"
        if ($debug &amp; 8);

      # call mechanism specific encoding routine
      my $x = $self-&gt;{conn}-&gt;encode(substr($data, $offset || 0, $bsz));
      print $fh pack('N', length($x)), $x;
      $len -= $bsz;
      $offset += $bsz;
    }

    return $_[2];
  }

}

1;
</pre></body></html>