in reply to Re^4: Using Threads For Simple SMTP Relay Server
in thread Using Threads For Simple SMTP Relay Server

Looking at Net::SMTP::Server::Client2, subclassing it is non-trivial because it uses a lexical dispatch table to invoke most of the methods you would want to override. As the dispatch table is built at compile time, overriding those methods in the usual way doesn't work.

Here's one way to do it, though I shall post a SoPW to see if anyone knows a better way.

The first thing you need is access to the dispatch table from within the subclass. To facilitate that, I added a class method to Client2.pm: 

sub get_dispatch_table { \%_cmds; }

[download]

Then a simple subclass that overrides the HELO and HELP commands looks like this: 

package Net::SMTP::Server::Client3;
use base qw[ Net::SMTP::Server::Client2 ];

sub _hello {
    shift->okay( "Yeah! You want summat?" );
}

sub _help {
    my $self = shift;
    $self->okay( 
        "Jeez! There's only 10 commands of 4 letters each. Try to keep
+ up!" 
    );
    $self->SUPER::_help;
}

my $dispatch = Net::SMTP::Server::Client2::get_dispatch_table;
$dispatch->{ HELO } = \&_hello;
$dispatch->{ HELP } = \&_help;

1;

[download]

Not hugely elegant, but it requires the minimum change to Client2.

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
"Too many [] have been sedated by an oppressive environment of political correctness and risk aversion."

Replies are listed 'Best First'.
Re^6: Using Threads For Simple SMTP Relay Server
by lamberms (Sexton) on Oct 30, 2007 at 13:23 UTC
    You are completely right about me breaking the protocol. I'm trying to show evidence of what is wrong and screwing it up. Perhaps this will illustrate better.

    Here is code using the Client3 library that uses fork: 

    # NOTE: We Could Write A Log Of Outgoing Email So That People Would Kn
+ow If Their Stuff Went Out
# Have to set RES_NAMESERVERS env to DNS server first
# This Version Of The Relayer Forks To Handle Multiple Connections
use strict;
use Carp;
use Net::SMTP::Server;
use Net::SMTP::Server::Client3;
use Net::SMTP_auth;
use File::Temp qw/ tempfile tempdir /;

# Server Code
# Globals
my $server = undef;
my $conn = undef;
# Create Temp Mail Directory For MIME files sent to this "SERVER"
if (not -d ".\\MailToBeSent") {
    mkdir ".\\MailToBeSent";
}
$server = new Net::SMTP::Server('192.168.10.68', 25) || croak("Unable 
+to handle client connection: $!\n");
while($conn = $server->accept()) {
    fork and last;
    $conn->close;
};
# End Server Code

# Client Code
print "Client Thread Started\n";
# Store Mail In Temp File (Otherwise Bad Things Happen ;-))
my ($fh, $filename) = tempfile(TEMPLATE => 'tempXXXXX',DIR => '.\MailT
+oBeSent',SUFFIX => '.dat');
my $client = new Net::SMTP::Server::Client3($conn,$fh) || croak("Unabl
+e to handle client: $!\n");
$client->greet; # this is new
while($client->get_message){ # this is different
    my $smtp = undef;
    my $to = "";
    my $line = "";
    print "Sending Message\n";
    # Send Confirmation Of Receipt To The Sender
    $client->okay("message saved for relay"); # this is new
    $client->_quit();
    # Relay With Perl Module Net::SMTP_auth to Mail Street Or usmail.b
+etalasermike.com
    $smtp = Net::SMTP_auth->new(
                           Host => 'hostname',
                           Hello => 'server.com',
                           Timeout => 30,
                          ); # Could add a Debug => 1, directive to ge
+t debug statements
    $smtp->auth('NTLM', 'user', 'pass');
    $smtp->mail('username@server.com');
    # Could Paste The $client->{FROM} Into The Body (Or Subject)
    # Add To Lines
    foreach $to (@{$client->{TO}}) {
        print "TO: $to\n";
        $smtp->to($to);
    }
    $smtp->data();
    open(IN,$filename);
    binmode(IN);
    while ($line = <IN>) {
        $smtp->datasend($line);
    }
    close(IN);
    $smtp->dataend();
    $smtp->quit;
    print "Message Sent\n";
    # End Relay With Perl Module Net::SMTP_auth
    close($fh);
    if (-e $filename) {
        unlink $filename;
    }
}
print "Client Thread Closing\n";
# Cleanup
exit;
# End Client Code

    [download]

    Here is the output when I send mail via this code: 

    Net::SMTP>>> Net::SMTP(2.31)
Net::SMTP>>>   Net::Cmd(2.29)
Net::SMTP>>>     Exporter(5.60)
Net::SMTP>>>   IO::Socket::INET(1.31)
Net::SMTP>>>     IO::Socket(1.30)
Net::SMTP>>>       IO::Handle(1.27)
Net::SMTP=GLOB(0x20f758c)<<< 220 Debatable SMTP 0.2 Ready.
Net::SMTP=GLOB(0x20f758c)>>> EHLO localhost.localdomain
Net::SMTP=GLOB(0x20f758c)<<< 250 OK Welcome
Net::SMTP=GLOB(0x20f758c)>>> MAIL FROM:<lamberms@betalasermike.com>
Net::SMTP=GLOB(0x20f758c)<<< 250 OK Envelope sender set to <lamberms@b
+etalasermi
ke.com>
Net::SMTP=GLOB(0x20f758c)>>> RCPT TO:<lamberms@betalasermike.com>
Net::SMTP=GLOB(0x20f758c)<<< 250 OK sending to lamberms@betalasermike.
+com
Net::SMTP=GLOB(0x20f758c)>>> DATA
Net::SMTP=GLOB(0x20f758c)<<< 354 And what am I to tell them?
Net::SMTP=GLOB(0x20f758c)>>> From: <lamberms@betalasermike.com>
Net::SMTP=GLOB(0x20f758c)>>> To: lamberms@betalasermike.com
Net::SMTP=GLOB(0x20f758c)>>> Cc:
Net::SMTP=GLOB(0x20f758c)>>> Subject: Problems Registering Software
Net::SMTP=GLOB(0x20f758c)>>> Hello.  I purchased the .Net Winforms Ult
+ra Pack an
d received serial number of 2F46BC380D.  However, when I try to instal
+l that sof
tware and use that serial number it wants to install as an evaluation.
+  What is
going on?
Net::SMTP=GLOB(0x20f758c)>>> Thanks,
Net::SMTP=GLOB(0x20f758c)>>> Steve
Net::SMTP=GLOB(0x20f758c)>>> .
Net::SMTP=GLOB(0x20f758c)<<< 250 OK message saved for relay
Net::SMTP=GLOB(0x20f758c)>>> QUIT

    [download]

    As you can see the email is sent properly. Here is the code I'm trying to use and having problems with: 

    # NOTE: We Could Write A Log Of Outgoing Email So That People Would Kn
+ow If Their Emails Went Out
# Have to set RES_NAMESERVERS env to DNS server first
# This Version Of The Relayer Uses Explicit Threads To Handle Multiple
+ Clients At Once
use strict;
use Carp;
use Net::SMTP::Server;
# Net::SMTP::Server::Client3 is just a version of Client2 I modified t
+o use temp
# files instead of in memory variables to store the Mime Message.  Thi
+s yielded
# better results with large MIME files.
use Net::SMTP::Server::Client3;
use Net::SMTP_auth;
use File::Temp qw/ tempfile tempdir /;
use threads;
use threads::shared;
use IO::Socket;

# Server Code
# Globals
my $server = undef;
my $conn = undef;
my $oldconn = undef;
my $oldconn_to_close = undef;
my $sockthread = undef;
my @threads = ();
my $numthreads = 2;
my $threadcounter = 0;
my %heartbeat : shared;
my @jobqueue : shared;
my @connections_to_kill : shared;
my @old_connections = ();
# Vivify The Share Variables
#@jobqueue = &share([]);
# Create Temp Mail Directory For MIME files sent to this "SERVER"
# Start Main Thread
if (not -d ".\\MailToBeSent") {
    mkdir ".\\MailToBeSent";
}
# NOTE: Probably should remove all files in .\MailToBeSent here
print "Deleting Temp Files\n";
opendir(DIR,".\\MailToBeSent");
my @files = grep (!/^\.\.?$/, readdir (DIR)); 
foreach my $file (@files) {
    unlink ".\\MailToBeSent\\$file" || print "Could Not Delete .\\Mail
+ToBeSent\\$file\n";
}
close(DIR);
# Create $numthreads threads and use them
for ($threadcounter = 0;$threadcounter < $numthreads;$threadcounter++)
+ {
    $sockthread = threads->new(\&thread_init);
    $sockthread->detach;
}
$server = new Net::SMTP::Server('192.168.10.68', 25) || croak("Unable 
+to handle client connection: $!\n");
while($conn = $server->accept()) {
    # Place connection on job queue
    # Push Onto A Non-Shared Array So That Connection Is Saved For Wor
+ker Thread
    push(@old_connections,$conn);
    {
        lock(@jobqueue);
        push(@jobqueue,$conn->fileno());
    }
    # Clean Up Old Connections
    {
        lock(@connections_to_kill);
        $oldconn_to_close = pop(@connections_to_kill);
        foreach $oldconn (@old_connections) {
            if ($oldconn->fileno() == $oldconn_to_close) {
                print "Closing Connection: " . $oldconn->fileno() . "\
+n";
                $oldconn->close();
            }
        }
    }

    # Check For Dead Threads using shared %heartbeat
};
# End Main Thread

# Start Worker Threads
sub thread_init {
    # Use thread::shared to read job queue (An Array with connection o
+bjects)
    # pop them off and service them.  We can use another hash in the f
+orm of
    # $heartbeat{$thread_number} = timestamp to give last time the thr
+ead
    # was active for the purposes of killing thread.  Then we should m
+onitor
    # the process to make sure it does not take too much memory.  If i
+t does
    # exit and re-launch
    my $thread_obj = threads->self();
    my $thread_number = $thread_obj->tid();
    my $process_jobs = -1;
    
    print "Launched Thread Number " . $thread_obj->tid() . "\n";
    # Main Event Loop
    while ($process_jobs) {
        # Exit on bad conditions or when told to by master?
        my $conn = undef;
        # Lock queue and get one Connection off to service by this wor
+ker thread
        {
            lock(@jobqueue);
            $conn = pop(@jobqueue);
        }
        if (defined($conn)) {
            # De-reference Connection
            open my $socket, '+<&=' . $conn or die $!;
            #print "SOCKET: $socket\n";
            print "Connection Being Serviced By Thread Number " . $thr
+ead_obj->tid() . "\n"; 
            serviceClient($socket);
            close($socket);
            # Put $conn on @connections_to_kill (this will be done in 
+the master thread)
            {
                lock(@connections_to_kill);
                push(@connections_to_kill,$conn);
            }
        }
        sleep(2);
    }
    return;
}

sub serviceClient {
    my $conn = $_[0];

    # Client Code
    print "Client Processing Started\n";
    # Store Mail In Temp File (Otherwise Bad Things Happen ;-))
    my ($fh, $filename) = tempfile(TEMPLATE => 'tempXXXXX',DIR => '.\M
+ailToBeSent',SUFFIX => '.dat');
    my $client = new Net::SMTP::Server::Client3($conn,$fh) || croak("U
+nable to handle client: $!\n");
    $client->greet; # this is new
    #print $conn "WOOT!\r\n";
    #print "GOT IN HERE\n";
    while($client->get_message){ # this is different
        #print "GOT IN HERE 2\n";
        my $smtp = undef;
        my $to = "";
        my $line = "";
        print "Sending Message\n";
        # Send Confirmation Of Receipt To The Sender
        $client->okay("message saved for relay"); # this is new
        $client->_quit();
        # Relay With Perl Module Net::SMTP_auth to Mail Street Or usma
+il.betalasermike.com
        $smtp = Net::SMTP_auth->new(
                               Host => 'hostname',
                               Hello => 'server.com',
                               Timeout => 30,
                              ); # Could add a Debug => 1, directive t
+o get debug statements
        $smtp->auth('NTLM', 'user', 'pass');
        $smtp->mail('username@server.com');
        # Could Paste The $client->{FROM} Into The Body (Or Subject)
        # Add To Lines
        foreach $to (@{$client->{TO}}) {
            print "TO: $to\n";
            $smtp->to($to);
        }
        $smtp->data();
        open(IN,$filename);
        binmode(IN);
        while ($line = <IN>) {
            $smtp->datasend($line);
        }
        close(IN);
        $smtp->dataend();
        $smtp->quit;
        print "Message Sent\n";
        # End Relay With Perl Module Net::SMTP_auth
        close($fh);
        if (-e $filename) {
            unlink $filename;
        }
    }
    print "Client Processing Finished\n";
    # End Client Code
}
# End Worker Threads

    [download]

    The only difference is that I'm treating the IO::Socket like an integer handle (This worked flawlessly for you as noted above). Here is the result of that code for me: 

    Net::SMTP>>> Net::SMTP(2.31)
Net::SMTP>>>   Net::Cmd(2.29)
Net::SMTP>>>     Exporter(5.60)
Net::SMTP>>>   IO::Socket::INET(1.31)
Net::SMTP>>>     IO::Socket(1.30)
Net::SMTP>>>       IO::Handle(1.27)
Net::SMTP=GLOB(0x20f758c)<<< 220 Debatable SMTP 0.2 Ready.
Net::SMTP=GLOB(0x20f758c)>>> EHLO localhost.localdomain
Net::SMTP=GLOB(0x20f758c)<<< EHLO localhost.localdomain

    [download]

    Here you can see that it never get EHLO command. The client receives the 220 Debatable SMTP message so it is obvious that the socket is Read Write. However, once it starts reading data from the client (EHLO commands) it is sending Welcome messages but they are never received by the other side. It is really weird that this code works on your system and does not work on mine.

[reply]
[d/l]
[select]
[reply]
        I took those lines out of it and so ... not broken anymore and yes, it works with Client2 with forking but not with threads. I get the exactly the same result with the unmodified Client2 module.
[reply]

In Section Seekers of Perl Wisdom