Net::Server::Mail::SMTP - A module to implement the SMTP protocole

    use Net::Server::Mail::SMTP;

    my @local_domains = qw(example.com example.org);
    my $server = new IO::Socket::INET Listen => 1, LocalPort => 25;

    my $conn;
    while($conn = $server->accept)
    {
        my $smtp = new Net::Server::Mail::SMTP socket => $conn;
        $smtp->set_callback(RCPT => \&validate_recipient);
        $smtp->set_callback(DATA => \&queue_message);
        $smtp->process();
        $conn->close()
    }

    sub validate_recipient
    {
        my($session, $recipient) = @_;

        my $domain;
        if($recipient =~ /@(.*)>\s*$/)
        {
            $domain = $1;
        }

        if(not defined $domain)
        {
            return(0, 513, 'Syntax error.');
        }
        elsif(not(grep $domain eq $_, @local_domains))
        {
            return(0, 554, "$recipient: Recipient address rejected: Relay access denied");
        }

        return(1);
    }

    sub queue_message
    {
        my($session, $data) = @_;

        my $sender = $session->get_sender();
        my @recipients = $session->get_recipients();

        return(0, 554, 'Error: no valid recipients')
            unless(@recipients);

        my $msgid = add_queue($sender, \@recipients, $data)
          or return(0);

        return(1, 250, "message queued $msgid");
    }

    sub helo_handle
    {
        my($session, $hostname) = @_;

        if($hostname eq 'localhost')
        {
            return(0, 553, q(I don't like this hostname, try again.));
        }

        # don't forgot to return a success reply if you are happy with
        # command's value
        return 1;
    }

package Net::Server::Mail::SMTP;

use 5.006;
use strict;
use base 'Net::Server::Mail';

our $VERSION = "0.17";

sub init
{
    my($self, @args) = @_;
    my $rv = $self->SUPER::init(@args);
    return $rv unless $rv eq $self;

    $self->def_verb(HELO => 'helo');
    $self->def_verb(VRFY => 'vrfy');
    $self->def_verb(EXPN => 'expn');
    $self->def_verb(TURN => 'turn');
    $self->def_verb(HELP => 'help');
    $self->def_verb(NOOP => 'noop');
    $self->def_verb(MAIL => 'mail');
    $self->def_verb(RCPT => 'rcpt');
    $self->def_verb(SEND => 'send');
    $self->def_verb(SOML => 'soml');
    $self->def_verb(SAML => 'saml');
    $self->def_verb(DATA => 'data');
    $self->def_verb(RSET => 'rset');
    $self->def_verb(QUIT => 'quit');

    # go to the initial step
    $self->step_reverse_path(0);
    $self->step_forward_path(0);
    $self->step_maildata_path(0);

    # handle data after the end of data indicator (.)
    $self->{data_handle_more_data} = 0;

    return $self;
}

sub step_reverse_path
{
    my($self, $bool) = @_;
    if(defined $bool)
    {
        $self->{reverse_path} = $bool;
    }

    return $self->{reverse_path};
}

sub step_forward_path
{
    my($self, $bool) = @_;
    if(defined $bool)
    {
        $self->{forward_path} = $bool;
    }

    return $self->{forward_path};
}

sub step_maildata_path
{
    my($self, $bool) = @_;
    if(defined $bool)
    {
        $self->{maildata_path} = $bool;
        # initialise data container
        if(not $bool)
        {
            $self->{_data} = '';
        }
    }

    return $self->{maildata_path};
}

sub get_protoname
{
    return 'SMTP';
}

sub get_sender
{
    my($self) = @_;
    my $sender = $self->step_reverse_path();
    return($sender ? $sender : undef);
}

sub get_recipients
{
    my($self) = @_;
    my $recipients = $self->step_forward_path();
    return(ref $recipients ? @$recipients : undef)
}

sub helo
{
    my($self, $hostname) = @_;

    unless(defined $hostname && length $hostname)
    {
        $self->reply(501, 'Syntax error in parameters or arguments');
        return;
    }

    $self->make_event
    (
        name => 'HELO',
        arguments => [$hostname],
        on_success => sub
        {
            # according to the RFC, HELO ensures "that both the SMTP client
            # and the SMTP server are in the initial state"
            $self->step_reverse_path(1);
            $self->step_forward_path(0);
            $self->step_maildata_path(0);
        },
        success_reply => [250, 'Requested mail action okay, completed'],
    );

    return;
}

sub noop
{
    my($self) = @_;
    $self->make_event(name => 'NOOP');
    return;
}

sub expn
{
    my($self, $address) = @_;
    $self->make_event
      (
       name => 'EXPN',
       arguments => [$address],
       default_reply => [502, 'Command not implemented']
      );
    return;
}

sub turn
{
    # deprecated in RFC 2821
    my($self) = @_;
    $self->reply(502, 'Command not implemented');
    $self->make_event
      (
       name => 'TURN',
       default_reply => [502, 'Command not implemented']
      );
    return;
}

sub vrfy
{
    my($self, $address) = @_;
    $self->make_event
      (
       name => 'VRFY',
       arguments => [$address],
       default_reply => [502, 'Command not implemented']
      );
    return;
}

sub help
{
    my($self, $command) = @_;
    $self->make_event
      (
       name => 'HELP',
       arguments => [$command],
       default_reply => [502, 'Command not implemented']
      );
    return;
}

sub mail
{
    my($self, $args) = @_;

    unless($self->step_reverse_path)
    {
        $self->reply(503, 'Bad sequence of commands');
        return;
    }


    unless($args =~ s/^from:\s*//i)
    {
        $self->reply(501, 'Syntax error in parameters or arguments');
        return;
    }

    if($self->step_forward_path)
    {
        $self->reply(503, 'Bad sequence of commands');
        return;
    }

    my($address, @options) = split(' ', $args);

    unless($self->handle_options('MAIL', $address, @options))
    {
        return;
    }

    $self->make_event
    (
        name => 'MAIL',
        arguments => [$address],
        on_success => sub
        {
            $self->step_reverse_path($address);
            $self->step_forward_path(1);
        },
        success_reply => [250, "sender $address OK"],
        failure_reply => [550, 'Failure'],
    );

    return;
}

sub rcpt
{
    my($self, $args) = @_;

    unless($self->step_forward_path)
    {
        $self->reply(503, 'Bad sequence of commands');
        return;
    }
    
    unless($args =~ s/^to:\s*//i)
    {
        $self->reply(501, 'Syntax error in parameters or arguments');
        return;
    }

    my($address, @options) = split(' ', $args);

    unless($self->handle_options('RCPT', $address, @options))
    {
        return;
    }

    $self->make_event
    (
        name => 'RCPT',
        arguments => [$address],
        on_success => sub
        {
            my $buffer = $self->step_forward_path();
            $buffer = [] unless ref $buffer eq 'ARRAY';
            push(@$buffer, $address);
            $self->step_forward_path($buffer);
            $self->step_maildata_path(1);
        },
        success_reply => [250, "recipient $address OK"],
        failure_reply => [550, 'Failure'],
    );

    return;
}

# we overwrite a perl command... we shouldn't need it in this class,
# but take care.
sub send
{
    my($self) = @_;
    $self->make_event
      (
       name => 'SEND',
       default_reply => [502, 'Command not implemented']
      );
    return;
}

sub soml
{
    my($self) = @_;
    $self->make_event
      (
       name => 'SOML',
       default_reply => [502, 'Command not implemented']
      );
    return;
}

sub saml
{
    my($self) = @_;
    $self->make_event
      (
       name => 'SAML',
       default_reply => [502, 'Command not implemented']
      );
    return;
}

sub data
{
    my($self, $args) = @_;

    unless($self->step_maildata_path)
    {
        $self->reply(503, 'Bad sequence of commands');
        return;
    }

    if(defined $args && length $args)
    {
        $self->reply(501, 'Syntax error in parameters or arguments');
        return;
    }

    $self->{last_chunk} = '';
    $self->make_event
      (
       name => 'DATA-INIT',
       on_success => sub {$self->next_input_to(\&data_part);},
       success_reply => [354, 'Start mail input; end with <CRLF>.<CRLF>']
      );

    return;
}

# Because data is cutted into pieces (4096 bytes), we have to search
# "\r\n.\r\n" sequence in 2 consecutive pieces. $self->{last_chunk}
# contains the last 5 bytes.
sub data_part
{
    my($self, $data) = @_;

    # search for end of data indicator
    if("$self->{last_chunk}$data" =~ /\r?\n\.\r?\n/s )
    {
        my $more_data = $';
        if(length $more_data)
        {
            # Client sent a command after the end of data indicator ".".
            if(!$self->{data_handle_more_data})
            {
                $self->reply(453, "Command received prior to completion of".
                                  " previous command sequence");
                return;
            }
        }
        
        # RFC 821 compliance.
        ($data = "$self->{last_chunk}$data") =~ s/(\r?\n)\.\r?\n(QUIT\r?\n)?$/$1/s;
        $self->{_data} .= $data;
        # RFC 2821 by the letter
        $self->{_data} =~ s/^\.(.+\015\012)(?!\n)/$1/gm;
        return $self->data_finished($more_data);
    }

    my $tmp = $self->{last_chunk};
    $self->{last_chunk} = substr $data, -5;
    $data = $tmp . substr $data, 0, -5;
    $self->make_event
      (
       name => 'DATA-PART',
       arguments => [\$data],
       on_success => sub
       {
           $self->{_data} .= $data;
           # please, recall me soon !
           $self->next_input_to(\&data_part);
       },
       success_reply => '', # don't send any reply !
      );

    return;
}

sub data_finished
{
    my($self, $more_data) = @_;

    $self->make_event
    (
        name => 'DATA',
        arguments => [\$self->{_data}],
        success_reply => [250, 'message sent'],
    );

    # reinitiate the connection
    $self->step_reverse_path(1);
    $self->step_forward_path(0);
    $self->step_maildata_path(0);

    # if more data, handle it
    if($more_data)
    {
        return $self->{process_operation}($self, $more_data);
    }
    else
    {
        return;
    }
}

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

    $self->make_event
    (
        name => 'RSET',
        on_success => sub
        {
            $self->step_reverse_path(1)
              if($self->step_reverse_path());
            $self->step_forward_path(0);
            $self->step_maildata_path(0);
        },
        success_reply => [250, 'Requested mail action okay, completed'],
    );

    return;
}

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

    $self->make_event
    (
        name => 'QUIT',
        success_reply => [221, $self->get_hostname . ' Service closing transmission channel'],
    );

    return 1; # close cnx
}

##########################################################################

sub handle_options
{
    # handle options for verb MAIL and RCPT
    my($self, $verb, $address, @options) = @_;

    if(@options)
    {
        $self->reply(555, "Unsupported option: $options[0]");
        return 0;
    }

    return 1;
}

1;