package Net::SMTP::Server::Client;
require 5.001;

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

require Exporter;
require AutoLoader;
#use Carp;
use IO::Socket;

@ISA    = qw(Exporter AutoLoader);
@EXPORT = qw();

$VERSION = '1.2.7';

my %_cmds = (
    DATA => \&_data,
    EXPN => \&_noway,
    HELO => \&_hello,
    HELP => \&_help,
    MAIL => \&_mail,
    NOOP => \&_noop,
    QUIT => \&_quit,
    RCPT => \&_receipt,
    RSET => \&_reset,
    VRFY => \&_noway,
    #
    EHLO => \&_ehlo,
    AUTH => \&_auth,
);

my %_auths = (
    LOGIN => \&_auth_login,
    PLAIN => \&_auth_plain,
);
my @_auths = qw(
  LOGIN
  PLAIN
);

# Utility functions.
sub _put {
    my $self = shift;

    print { $self->{SOCK} } "@_\r\n";

    if ( $self->{DEBUG} or $self->{DEBUG_LOG} ) {
        print { $self->{log_fh} } "S: ", @_, "\n";
    }
}

sub _reset {
    my $self = shift;

    $self->{FROM} = undef;
    $self->{TO}   = [];
    #
    $self->{authmethod} = undef;
    $self->{user}       = undef;
    $self->{pass}       = undef;

    $self->_put("250 Fine fine.");
}

###

# Set forced SMTP Auth
sub force_login {
    my $self = shift;
    my $val  = shift;

    if ( defined $val ) {
        $self->{FORCE_LOGIN} = $val;
    }
    return $self->{FORCE_LOGIN};
}

# Set debug level
sub debug {
    my $self = shift;
    my $val  = shift;

    if ( defined $val ) {
        $self->{DEBUG} = $val;
    }
    return $self->{DEBUG};
}

# Set debug log
sub debug_log {
    my $self = shift;
    my $val  = shift;

    if ( defined ($val) and length($val) and $val ) {
		$self->{DEBUG_LOG} = $val;
		# Workaround wegen Problemen mit STDERR auf Windows
		close $self->{log_fh}; 
		delete $self->{log_fh}; 
        open( $self->{log_fh}, '>>', $self->{DEBUG_LOG} )
          or die "Cant open debug log '$self->{DEBUG_LOG}'";
		flock $self->{log_fh},0;
		use IO::Handle;
		$self->{log_fh}->autoflush(1);

    }
    return $self->{DEBUG_LOG};
}

### New instance.
sub new {
    my ( $this, $sock ) = @_;

    my $class = ref($this) || $this;
    my $self = {};

    $self->{DEBUG}       = 0;        # Debuglevel
    $self->{DEBUG_LOG}   = undef;    # Logfile
    $self->{FORCE_LOGIN} = 1;        # SMTP-Authentifizierung erzwingen
    $self->{log_fh} 	 = *STDERR;  # output debug info to STDERR

    $self->{FROM} = undef;
    $self->{TO}   = [];
    $self->{MSG}  = undef;
    $self->{SOCK} = $sock;

    #
    $self->{authmethod} = undef;
    $self->{user}       = undef;
    $self->{pass}       = undef;
    $self->{logindb}    = undef;
    #

    bless( $self, $class );

    die "No client connection specified." unless defined( $self->{SOCK} );

    return $self;
}

sub process {
    my $self = shift;
    my ( $cmd, @args );

    $self->_put("220 MacGyver SMTP Ready.");

    my $sock = $self->{SOCK};

    while ( my $line = <$sock> ) {
        chomp $line;

        if ( $self->{DEBUG} or $self->{DEBUG_LOG} ) {
            print { $self->{log_fh} } "C: ", $line, "\n";
        }

        # Clean up.
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;
        if ( not length $line ) {
            $self->_put("500 Learn to type!");
            next;
        }

        ( $cmd, @args ) = split /\s+/, $line;
        $cmd =~ tr/a-z/A-Z/;

        if ( !defined( $_cmds{$cmd} ) ) {
            $self->_put("500 Learn to type!");
            next;
        }

        return ( defined( $self->{MSG} ) ? 1 : 0 )
          unless &{ $_cmds{$cmd} }( $self, \@args );
    }

    return undef;
}

# ------------------
use Sys::Hostname;

sub _ehlo {
    my $self = shift;
    my @args = @{ shift() };

    my $host = Sys::Hostname::hostname;
    $self->_put("250-$host Hello @args");
    $self->_put("250 AUTH @_auths");
}

sub logindb {
    my $self = shift;
    $self->{logindb}{path} = shift;
    1;
}

sub __check_login {
    my ( $self, $user, $pass ) = @_;
    return if not length $user;
    return if not length $pass;

    die "Login database ", $self->{logindb}{path}, " missing!"
      if not length $self->{logindb}{path};

    if ( open my $db, '<', $self->{logindb}{path} ) {
        my @logins = <$db>;
        chomp @logins;
        my ($line) = grep /^\Q$user\E\s/, @logins;
        my ( $found_user, $found_pass ) = split /\s+/, $line;

        return ( $found_user eq $user and $found_pass eq $pass );
    }
    else {
        die "Login database ", $self->{logindb}{path}, " missing!";
    }
}

use MIME::Base64;

sub _auth_plain {
    my $self = shift;
    my @args = @{ shift() };

    my $line;
    if ( not @args ) {
        $self->_put("334");
        my $sock = $self->{SOCK};
        $line = <$sock>;
        chomp $line;

        if ( $self->{DEBUG} or $self->{DEBUG_LOG} ) {
            print { $self->{log_fh} } "C: ", $line, "\n";
        }
    }
    else {
        $line = "@args";
    }

    chomp $line;
    ( undef, $self->{user}, $self->{pass}, undef )
      = ( split /\x00/, decode_base64($line) );
}

sub _auth_login {
    my $self = shift;
    my $sock = $self->{SOCK};

    if ( not length $self->{user} ) {
        $self->_put("334 VXNlcm5hbWU6");    # Username:
        $self->{user} = <$sock>;
        chomp $self->{user};

        if ( $self->{DEBUG} or $self->{DEBUG_LOG} ) {
            print { $self->{log_fh} } "C: ", $self->{user}, "\n";
        }

        $self->{user} = decode_base64( $self->{user} );
    }

    if ( not length $self->{pass} ) {
        $self->_put("334 UGFzc3dvcmQ6");    # Password:
        $self->{pass} = <$sock>;
        chomp $self->{pass};

        if ( $self->{DEBUG} or $self->{DEBUG_LOG} ) {
            print { $self->{log_fh} } "C: ", $self->{pass}, "\n";
        }

        $self->{pass} = decode_base64( $self->{pass} );
    }
}

sub _auth {
    my $self = shift;
    my $args = shift;

    $self->{authmethod} = shift @$args;
    $self->{loggedin}   = undef;
    $self->{user}       = undef;
    $self->{pass}       = undef;

    if ( $_auths{ $self->{authmethod} } ) {
        &{ $_auths{ $self->{authmethod} } }( $self, $args )
          ;    #get login with AUTH ....

        if ( $self->{user} and $self->{pass} ) {
            $self->{loggedin}
              = $self->__check_login( $self->{user}, $self->{pass} );
        }

        if ( not length $self->{user} ) {
            $self->_put("503 OMG. I cant gess your user login!");
        }
        elsif ( not length $self->{pass} ) {
            $self->_put("503 Really? Give me your password!");
        }
        elsif ( $self->{loggedin} ) {
            $self->_put("235 2.7.0 Authentication successful");
        }
        else {
            $self->_put(
                "535 Authentication failed. Restarting authentication process."
            );
        }
    }
    else {
        $self->_put("504 Authentication mechanism not supported.");
    }
}

# ----------

sub _fromto {
    my $self = shift;
    my ( $which, $var, $args ) = @_;

    if ( !( $$args[0] =~ /^$which\s*([^\s]+)/i ) ) {
        if ( !$$args[1] || !( $$args[0] =~ /^$which$/i ) ) {
            $self->_put("501 Bzzzz.");
            return -1;
        }

        ref($var) eq 'ARRAY'
          ? ( push @$var, $$args[1] )
          : ( $$var = $$args[1] );
    }

    ref($var) eq 'ARRAY' ? ( push @$var, $1 ) : ( $$var = $1 )
      unless !defined($1);

    $self->_put("250 Ok...got it.");
}

sub _mail {
    my $self = shift;
    return $self->_fromto( 'FROM:', \$self->{FROM}, @_ );
}

sub _receipt {
    my $self = shift;
    return $self->_fromto( 'TO:', \@{ $self->{TO} }, @_ );
}

sub _data {
    my $self = shift;
    my $done = undef;

    if ( !defined( $self->{FROM} ) ) {
        $self->_put("503 Yeah, right.  Tell me who you are first!");
        return 1;
    }

    if ( !defined( $self->{TO} ) ) {
        $self->_put(
            "503 You want me to read your mind?  Tell me who to send it to!");
        return 1;
    }

    if ( $self->{FORCE_LOGIN} and not $self->{loggedin} ) {
        $self->_put("530 5.7.0  Authentication required");
        return 1;
    }

    $self->_put("354 Give it to me, big daddy.");

    my $sock = $self->{SOCK};
    while ( my $line = <$sock> ) {

        if ( $self->{DEBUG} or $self->{DEBUG_LOG} ) {
            print { $self->{log_fh} } "C: ", $line;
        }

        if ( $line =~ /^\.\r\n$/ ) {
            $done = 1;
            last;
        }

        # RFC 821 compliance.
        $line =~ s/^\.\./\./;
        $self->{MSG} .= $line;
    }

    if ( !defined($done) ) {
        $self->_put("550 Fine...who needs you anyway!");
        return 1;
    }

    $self->_put("250 I got it darlin'.");
}

sub _noway {
    shift->_put("252 Nice try.");
}

sub _noop {
    shift->_put("250 Whatever.");
}

sub _help {
    my $self  = shift;
    my $i     = 0;
    my $str   = "214-Commands\r\n";
    my $total = keys(%_cmds);

    foreach ( sort( keys(%_cmds) ) ) {
        if ( !( $i++ % 5 ) ) {
            if ( ( $total - $i ) < 5 ) {
                $str .= "\r\n214 ";
            }
            else {
                $str .= "\r\n214-";
            }
        }
        else {
            $str .= ' ';
        }

        $str .= $_;
    }

    $self->_put($str);
}

sub _quit {
    my $self = shift;

    $self->_put("221 Good.");
    $self->{SOCK}->close;
    return 0;
}

sub _hello {
    shift->_put("250 You're polite.");
}

1;
__END__
# POD begins here.

=head1 NAME

Net::SMTP::Server::Client - Client session handling for Net::SMTP::Server.

=head1 SYNOPSIS

  use Carp;
  use Net::SMTP::Server;
  use Net::SMTP::Server::Client;
  use Net::SMTP::Server::Relay;

  $server = new Net::SMTP::Server('localhost', 25) ||
    croak("Unable to handle client connection: $!\n");

  while($conn = $server->accept()) {
    # We can perform all sorts of checks here for spammers, ACLs,
    # and other useful stuff to check on a connection.

    # Handle the client's connection and spawn off a new parser.
    # This can/should be a fork() or a new thread,
    # but for simplicity...
    my $client = new Net::SMTP::Server::Client($conn) ||
	croak("Unable to handle client connection: $!\n");

    # Process the client.  This command will block until
    # the connecting client completes the SMTP transaction.
    $client->process || next;
    
    # In this simple server, we're just relaying everything
    # to a server.  If a real server were implemented, you
    # could save email to a file, or perform various other
    # actions on it here.
    my $relay = new Net::SMTP::Server::Relay($client->{FROM},
					     $client->{TO},
					     $client->{MSG});
  }

=head1 DESCRIPTION

The Net::SMTP::Server::Client module implements all the session
handling required for a Net::SMTP::Server::Client connection.  The
above example demonstrates how to use Net::SMTP::Server::Client with
Net::SMTP::Server to handle SMTP connections.

$client = new Net::SMTP::Server::Client($conn)

Net::SMTP::Server::Client accepts one argument that must be a handle
to a connection that will be used for communication.

Once you have a new client session, simply call:

$client->process

This processes an SMTP transaction.  THIS MAY APPEAR TO HANG --
ESPECIALLY IF THERE IS A LARGE AMOUNT OF DATA BEING SENT.  Once this
method returns, the server will have processed an entire SMTP
transaction, and is ready to continue.

Once $client->process returns, various fields have been filled in.
Those are:

  $client->{TO}    -- This is an array containing the intended
                      recipients for this message.  There may be
                      multiple recipients for any given message.

  $client->{FROM}  -- This is the sender of the given message.
  $client->{MSG}   -- The actual message data. :)

=head1 AUTHOR AND COPYRIGHT
Net::SMTP::Server / SMTP::Server is Copyright(C) 1999, 
  MacGyver (aka Habeeb J. Dihu) <macgyver@tos.net>.  ALL RIGHTS RESERVED.

You may distribute this package under the terms of either the GNU
General Public License or the Artistic License, as specified in the
Perl README file. 

=head1 SEE ALSO

Net::SMTP::Server::Server, Net::SMTP::Server::Relay

=cut