Re: Contribution- persistent connection code for Mail::Transport::SMTP

Eugene L Schulman <[email protected]> Fri, 3 Jun 2005 19:22:09 -0400
Newsgroups gmane.comp.lang.perl.modules.mail-box
Message-ID <OF3449C303.D6AC0768-ON85257015.007FD86A-85257015.00805F84@us.ibm.com>
This is a multipart message in MIME format.
--=_alternative 0080587585257015_=
Content-Type: text/plain; charset="US-ASCII"

Repost of the attachment in the previous message as text for the benefit 
of the MARC mailing list.

                Respectfully Yours,
                Gene Schulman

---

Eugene L. Schulman
Senior Consultant and Technical Architect
IBM Global Services



Variant of Mail::Transport::SMTP with connection persistence:

use strict;
use warnings;

package Mail::Transport::SMTP;
use vars '$VERSION';
$VERSION = '2.060';
use base 'Mail::Transport::Send';

use Net::SMTP;

# ELS 2005-Jun-02
# Hash for persistent SMTP connections
# In this implementation, the hash will consist of pairs of hostname and 
Net::SMTP reference.
# The consumers of this variable are trySend_persist() and 
contactAnyServer_persist()


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

        $self->{'connx_persist'}={} #ELS
         unless (exists($self->{'connx_persist'}));

    my $hosts   = $args->{hostname};
    unless($hosts)
    {   require Net::Config;
        $hosts  = $Net::Config::NetConfig{smtp_hosts};
        undef $hosts unless @$hosts;
        $args->{hostname} = $hosts;
    }

    $args->{via}  ||= 'smtp';
    $args->{port} ||= '25';

    $self->SUPER::init($args) or return;

    my $helo = $args->{helo}
      || eval { require Net::Config; $Net::Config::inet_domain }
      || eval { require Net::Domain; Net::Domain::hostfqdn() };

    $self->{MTS_net_smtp_opts}
       = { Hello   => $helo
         , Debug   => ($args->{smtp_debug} || 0)
         };

warn "ELS: Using doctored Mail::Transport::SMTP";
    $self;
}

#------------------------------------------


sub trySend($@)
{   my ($self, $message, %args) = @_;

    # From whom is this message.
    my $from = $args{from} || $message->sender || '<>';
    $from = $from->address if ref $from && $from->isa('Mail::Address');

    # Who are the destinations.
    if(defined $args{To})
    {   $self->log(WARNING =>
   "Use option `to' to overrule the destination: `To' would refer to a 
field");
    }

    my @to = map {$_->address} $self->destinations($message, $args{to});

    unless(@to)
    {   $self->log(NOTICE =>
            'No addresses found to send the message to, no connection 
made');
        return 1;
    }

    # Prepare the header
    my @header;
    require IO::Lines;
    my $lines = IO::Lines->new(\@header);
    $message->head->printUndisclosed($lines);

    #
    # Send
    #

    if(wantarray)
    {   # In LIST context
        my $server;
        return (0, 500, "Connection Failed", "CONNECT", 0)
            unless $server = $self->contactAnyServer;

        return (0, $server->code, $server->message, 'FROM', $server->quit)
            unless $server->mail($from);

        foreach (@to)
        {     next if $server->to($_);
# must we be able to disable this?
# next if $args{ignore_erroneous_destinations}
              return (0, $server->code, $server->message,"To 
$_",$server->quit);
        }

        $server->data;
        $server->datasend($_) foreach @header;
        my $bodydata = $message->body->file;

        if(ref $bodydata eq 'GLOB') { $server->datasend($_) while 
<$bodydata> }
        else    { while(my $l = $bodydata->getline) { 
$server->datasend($l) } }

        return (0, $server->code, $server->message, 'DATA', $server->quit)
            unless $server->dataend;

        return ($server->quit, $server->code, $server->message, 'QUIT',
                $server->code);
    }

    # in SCALAR context
    my $server;
    return 0 unless $server = $self->contactAnyServer;

    $server->quit, return 0
        unless $server->mail($from);

    foreach (@to)
    {
          next if $server->to($_);
# must we be able to disable this?
# next if $args{ignore_erroneous_destinations}
          $server->quit;
          return 0;
    }

    $server->data;
    $server->datasend($_) foreach @header;
    my $bodydata = $message->body->file;

    if(ref $bodydata eq 'GLOB') { $server->datasend($_) while <$bodydata> 
}
    else    { while(my $l = $bodydata->getline) { $server->datasend($l) } 
}

    $server->quit, return 0
        unless $server->dataend;

    $server->quit;
}

#------------------------------------------


sub trySend_persist($@)
{   my ($self, $message, %args) = @_;


    # From whom is this message.
    my $from = $args{from} || $message->sender || '<>';
    $from = $from->address if ref $from && $from->isa('Mail::Address');

    # Who are the destinations.
    if(defined $args{To})
    {   $self->log(WARNING =>
   "Use option `to' to overrule the destination: `To' would refer to a 
field");
    }

    my @to = map {$_->address} $self->destinations($message, $args{to});

    unless(@to)
    {   $self->log(NOTICE =>
            'No addresses found to send the message to, no connection 
made');
        return 1;
    }

    # Prepare the header
    my @header;
    require IO::Lines;
    my $lines = IO::Lines->new(\@header);
    $message->head->printUndisclosed($lines);

    #
    # Send
    #

        my ($server,$chosenhost)=$self->contactAnyServer_persist;

        # ELS: If the process using the library is threaded, make sure 
that there
        #  is an advisory lock on the reference to the Net::SMTP 
connection object.
        #  That way, only one thread writes a transaction to this 
particular connection
        #  at one time.  This does not preclude the use of other 
connections.
        lock $self->{'connx_persist'}->{$chosenhost} if $server;

    if(wantarray)
    {   # In LIST context

        unless($server)
        {
                return (0, 500, "Connection Failed", "CONNECT", 0)
        }
        unless($server->mail($from))
        {
                my @retval=(0, $server->code, $server->message, 'FROM', 
$server->quit);
                delete $self->{'connx_persist'}->{$chosenhost};
                return @retval;
        }

        foreach (@to)
        {     next if $server->to($_);
# must we be able to disable this?
# next if $args{ignore_erroneous_destinations}
                my @retval=(0, $server->code, $server->message,"To 
$_",$server->quit);
                delete $self->{'connx_persist'}->{$chosenhost};
                return @retval;
        }

        $server->data;
        $server->datasend($_) foreach @header;
        my $bodydata = $message->body->file;

        if(ref $bodydata eq 'GLOB') { $server->datasend($_) while 
<$bodydata> }
        else    { while(my $l = $bodydata->getline) { 
$server->datasend($l) } }

        unless($server->dataend)
        {
                my @retval=(0, $server->code, $server->message, 'DATA', 
$server->quit);
                delete $self->{'connx_persist'}->{$chosenhost};
                return @retval;
        }

        return (1, $server->code, $server->message, 'NOOP', 
$server->code);
    }

        # in SCALAR context
        return 0 unless $server;

        unless($server->mail($from))
        {
                $server->quit;
                delete $self->{'connx_persist'}->{$chosenhost};
                return 0;
        }

        foreach (@to)
        {
                next if $server->to($_);
# must we be able to disable this?
# next if $args{ignore_erroneous_destinations}
                $server->quit;
                delete $self->{'connx_persist'}->{$chosenhost};
                return 0;
        }

        $server->data;
        $server->datasend($_) foreach @header;
        my $bodydata = $message->body->file;

        if(ref $bodydata eq 'GLOB') { $server->datasend($_) while 
<$bodydata> }
        else    { while(my $l = $bodydata->getline) { 
$server->datasend($l) } }

        unless($server->dataend)
        {
            $server->quit;
            delete $self->{'connx_persist'}->{$chosenhost};
            return 0;
        }
        1;
        # ELS Implicit unlock $self->{'connx_persist'}->{$chosenhost} as 
exit scope;
}

#------------------------------------------


sub contactAnyServer()
{   my $self = shift;

    my ($enterval, $count, $timeout) = $self->retry;
    my ($host, $port, $username, $password) = $self->remoteHost;
    my @hosts = ref $host ? @$host : $host;

    foreach my $host (@hosts)
    {   my $server = $self->tryConnectTo
         ( $host, Port => $port,
         , %{$self->{MTS_net_smtp_opts}}, Timeout => $timeout
         );

        defined $server or next;

        $self->log(PROGRESS => "Opened SMTP connection to $host.");

        if(defined $username)
        {   if($server->auth($username, $password))
            {    $self->log(PROGRESS => "$host: Authentication 
succeeded.");
            }
            else
            {    $self->log(ERROR => "Authentication failed.");
                 return undef;
            }
        }

        return $server;
    }

    undef;
}

#------------------------------------------

sub contactAnyServer_persist()
{   my $self = shift;

    my ($enterval, $count, $timeout) = $self->retry;
    my ($host, $port, $username, $password) = $self->remoteHost;
    my @hosts = ref $host ? @$host : $host;

    foreach my $host (@hosts)
    {   my ($server);
           if(exists($self->{'connx_persist'}->{$host})) #ELS
           {
                   $server=$self->{'connx_persist'}->{$host};
                   lock $self->{'connx_persist'}->{$host} if $server;
                   unless ($server->reset)
                   {
                           delete($self->{'connx_persist'}->{$host});
                           next;
                   }
                   # Implicit unlock $self->{'connx_persist'}->{$host}
           }
           else
           {
                  $server = $self->tryConnectTo
                  ( $host, Port => $port,
                  , %{$self->{MTS_net_smtp_opts}}, Timeout => $timeout
                  );

                defined $server or next;
 
                 $self->log(PROGRESS => "Opened SMTP connection to 
$host.");
 
                 if(defined $username)
                 {   if($server->auth($username, $password))
                     {    $self->log(PROGRESS => "$host: Authentication 
succeeded.");
                     }
                     else
                     {    $self->log(ERROR => "Authentication failed.");
                          return undef;
                     }
                 }
 
                 $self->{'connx_persist'}->{$host}=$server;
           }
        return ($server,$host);
    }

    undef;
}

#------------------------------------------


sub tryConnectTo($@)
{   my ($self, $host) = (shift, shift);
    Net::SMTP->new($host, @_);
}

#------------------------------------------

sub DESTROY($)  #ELS
{
                my $self=shift;
                foreach my $connx (values %{$self->{'connx_persist'}})
                {
                        $connx->quit;
                }
}


1;







Eugene L Schulman/Edison/IBM 
06/03/2005 06:50 PM

To
[email protected]
cc

Subject
Contribution- persistent connection code for Mail::Transport::SMTP






 


--=_alternative 0080587585257015_=
Content-Type: text/html; charset="US-ASCII"


<br><font size=2 face="sans-serif">Repost of the attachment in the previous
message as text for the benefit of the MARC mailing list.</font>
<br>
<br><font size=2 face="sans-serif">&nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; Respectfully Yours,</font>
<br><font size=2 face="sans-serif">&nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; Gene Schulman</font>
<br>
<br><font size=2 face="sans-serif">---</font>
<br><font size=2 face="sans-serif"><br>
</font><font size=2 color=blue face="Arial">Eugene L. Schulman</font>
<br><font size=1 color=blue>Senior Consultant and Technical Architect</font>
<br><font size=1 color=blue>IBM Global Services</font>
<br>
<br>
<br>
<br><font size=2 face="sans-serif">Variant of Mail::Transport::SMTP with
connection persistence:</font>
<br>
<div>
<br><font size=1 face="Courier New">use strict;<br>
use warnings;</font>
<br>
<br><font size=1 face="Courier New">package Mail::Transport::SMTP;<br>
use vars '$VERSION';<br>
$VERSION = '2.060';<br>
use base 'Mail::Transport::Send';</font>
<br>
<br><font size=1 face="Courier New">use Net::SMTP;</font>
<br>
<br><font size=1 face="Courier New"># ELS 2005-Jun-02<br>
# Hash for persistent SMTP connections<br>
# In this implementation, the hash will consist of pairs of hostname and
Net::SMTP reference.<br>
# The consumers of this variable are trySend_persist() and contactAnyServer_persist()</font>
<br>
<br>
<br><font size=1 face="Courier New">sub init($)<br>
{ &nbsp; my ($self, $args) = @_;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; $self-&gt;{'connx_persist'}={}
#ELS<br>
 &nbsp; &nbsp; &nbsp; &nbsp; unless (exists($self-&gt;{'connx_persist'}));</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; my $hosts &nbsp; = $args-&gt;{hostname};<br>
 &nbsp; &nbsp;unless($hosts)<br>
 &nbsp; &nbsp;{ &nbsp; require Net::Config;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;$hosts &nbsp;= $Net::Config::NetConfig{smtp_hosts};<br>
 &nbsp; &nbsp; &nbsp; &nbsp;undef $hosts unless @$hosts;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;$args-&gt;{hostname} = $hosts;<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; $args-&gt;{via} &nbsp;||=
'smtp';<br>
 &nbsp; &nbsp;$args-&gt;{port} ||= '25';</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; $self-&gt;SUPER::init($args)
or return;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; my $helo = $args-&gt;{helo}<br>
 &nbsp; &nbsp; &nbsp;|| eval { require Net::Config; $Net::Config::inet_domain
}<br>
 &nbsp; &nbsp; &nbsp;|| eval { require Net::Domain; Net::Domain::hostfqdn()
};</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; $self-&gt;{MTS_net_smtp_opts}<br>
 &nbsp; &nbsp; &nbsp; = { Hello &nbsp; =&gt; $helo<br>
 &nbsp; &nbsp; &nbsp; &nbsp; , Debug &nbsp; =&gt; ($args-&gt;{smtp_debug}
|| 0)<br>
 &nbsp; &nbsp; &nbsp; &nbsp; };</font>
<br>
<br><font size=1 face="Courier New">warn &quot;ELS: Using doctored Mail::Transport::SMTP&quot;;<br>
 &nbsp; &nbsp;$self;<br>
}</font>
<br>
<br><font size=1 face="Courier New">#------------------------------------------</font>
<br>
<br>
<br><font size=1 face="Courier New">sub trySend($@)<br>
{ &nbsp; my ($self, $message, %args) = @_;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; # From whom is this message.<br>
 &nbsp; &nbsp;my $from = $args{from} || $message-&gt;sender || '&lt;&gt;';<br>
 &nbsp; &nbsp;$from = $from-&gt;address if ref $from &amp;&amp; $from-&gt;isa('Mail::Address');</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; # Who are the destinations.<br>
 &nbsp; &nbsp;if(defined $args{To})<br>
 &nbsp; &nbsp;{ &nbsp; $self-&gt;log(WARNING =&gt;<br>
 &nbsp; &quot;Use option `to' to overrule the destination: `To' would refer
to a field&quot;);<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; my @to = map {$_-&gt;address}
$self-&gt;destinations($message, $args{to});</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; unless(@to)<br>
 &nbsp; &nbsp;{ &nbsp; $self-&gt;log(NOTICE =&gt;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;'No addresses found to send the
message to, no connection made');<br>
 &nbsp; &nbsp; &nbsp; &nbsp;return 1;<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; # Prepare the header<br>
 &nbsp; &nbsp;my @header;<br>
 &nbsp; &nbsp;require IO::Lines;<br>
 &nbsp; &nbsp;my $lines = IO::Lines-&gt;new(\@header);<br>
 &nbsp; &nbsp;$message-&gt;head-&gt;printUndisclosed($lines);</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; #<br>
 &nbsp; &nbsp;# Send<br>
 &nbsp; &nbsp;#</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; if(wantarray)<br>
 &nbsp; &nbsp;{ &nbsp; # In LIST context<br>
 &nbsp; &nbsp; &nbsp; &nbsp;my $server;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;return (0, 500, &quot;Connection Failed&quot;,
&quot;CONNECT&quot;, 0)<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;unless $server = $self-&gt;contactAnyServer;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; return
(0, $server-&gt;code, $server-&gt;message, 'FROM', $server-&gt;quit)<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;unless $server-&gt;mail($from);</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; foreach
(@to)<br>
 &nbsp; &nbsp; &nbsp; &nbsp;{ &nbsp; &nbsp; next if $server-&gt;to($_);<br>
# must we be able to disable this?<br>
# next if $args{ignore_erroneous_destinations}<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;return (0, $server-&gt;code,
$server-&gt;message,&quot;To $_&quot;,$server-&gt;quit);<br>
 &nbsp; &nbsp; &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; $server-&gt;data;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;$server-&gt;datasend($_) foreach @header;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;my $bodydata = $message-&gt;body-&gt;file;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; if(ref
$bodydata eq 'GLOB') { $server-&gt;datasend($_) while &lt;$bodydata&gt;
}<br>
 &nbsp; &nbsp; &nbsp; &nbsp;else &nbsp; &nbsp;{ while(my $l = $bodydata-&gt;getline)
{ $server-&gt;datasend($l) } }</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; return
(0, $server-&gt;code, $server-&gt;message, 'DATA', $server-&gt;quit)<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;unless $server-&gt;dataend;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; return
($server-&gt;quit, $server-&gt;code, $server-&gt;message, 'QUIT',<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;$server-&gt;code);<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; # in SCALAR context<br>
 &nbsp; &nbsp;my $server;<br>
 &nbsp; &nbsp;return 0 unless $server = $self-&gt;contactAnyServer;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; $server-&gt;quit, return
0<br>
 &nbsp; &nbsp; &nbsp; &nbsp;unless $server-&gt;mail($from);</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; foreach (@to)<br>
 &nbsp; &nbsp;{<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;next if $server-&gt;to($_);<br>
# must we be able to disable this?<br>
# next if $args{ignore_erroneous_destinations}<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;$server-&gt;quit;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;return 0;<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; $server-&gt;data;<br>
 &nbsp; &nbsp;$server-&gt;datasend($_) foreach @header;<br>
 &nbsp; &nbsp;my $bodydata = $message-&gt;body-&gt;file;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; if(ref $bodydata eq 'GLOB')
{ $server-&gt;datasend($_) while &lt;$bodydata&gt; }<br>
 &nbsp; &nbsp;else &nbsp; &nbsp;{ while(my $l = $bodydata-&gt;getline)
{ $server-&gt;datasend($l) } }</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; $server-&gt;quit, return
0<br>
 &nbsp; &nbsp; &nbsp; &nbsp;unless $server-&gt;dataend;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; $server-&gt;quit;<br>
}</font>
<br>
<br><font size=1 face="Courier New">#------------------------------------------</font>
<br>
<br>
<br><font size=1 face="Courier New">sub trySend_persist($@)<br>
{ &nbsp; my ($self, $message, %args) = @_;</font>
<br>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; # From whom is this message.<br>
 &nbsp; &nbsp;my $from = $args{from} || $message-&gt;sender || '&lt;&gt;';<br>
 &nbsp; &nbsp;$from = $from-&gt;address if ref $from &amp;&amp; $from-&gt;isa('Mail::Address');</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; # Who are the destinations.<br>
 &nbsp; &nbsp;if(defined $args{To})<br>
 &nbsp; &nbsp;{ &nbsp; $self-&gt;log(WARNING =&gt;<br>
 &nbsp; &quot;Use option `to' to overrule the destination: `To' would refer
to a field&quot;);<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; my @to = map {$_-&gt;address}
$self-&gt;destinations($message, $args{to});</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; unless(@to)<br>
 &nbsp; &nbsp;{ &nbsp; $self-&gt;log(NOTICE =&gt;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;'No addresses found to send the
message to, no connection made');<br>
 &nbsp; &nbsp; &nbsp; &nbsp;return 1;<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; # Prepare the header<br>
 &nbsp; &nbsp;my @header;<br>
 &nbsp; &nbsp;require IO::Lines;<br>
 &nbsp; &nbsp;my $lines = IO::Lines-&gt;new(\@header);<br>
 &nbsp; &nbsp;$message-&gt;head-&gt;printUndisclosed($lines);</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; #<br>
 &nbsp; &nbsp;# Send<br>
 &nbsp; &nbsp;#</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; my
($server,$chosenhost)=$self-&gt;contactAnyServer_persist;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; #
ELS: If the process using the library is threaded, make sure that there<br>
 &nbsp; &nbsp; &nbsp; &nbsp;# &nbsp;is an advisory lock on the
reference to the Net::SMTP connection object.<br>
 &nbsp; &nbsp; &nbsp; &nbsp;# &nbsp;That way, only one thread writes
a transaction to this particular connection<br>
 &nbsp; &nbsp; &nbsp; &nbsp;# &nbsp;at one time. &nbsp;This does
not preclude the use of other connections.<br>
 &nbsp; &nbsp; &nbsp; &nbsp;lock $self-&gt;{'connx_persist'}-&gt;{$chosenhost}
if $server;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; if(wantarray)<br>
 &nbsp; &nbsp;{ &nbsp; # In LIST context</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; unless($server)<br>
 &nbsp; &nbsp; &nbsp; &nbsp;{<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;return
(0, 500, &quot;Connection Failed&quot;, &quot;CONNECT&quot;, 0)<br>
 &nbsp; &nbsp; &nbsp; &nbsp;}<br>
 &nbsp; &nbsp; &nbsp; &nbsp;unless($server-&gt;mail($from))<br>
 &nbsp; &nbsp; &nbsp; &nbsp;{<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;my
@retval=(0, $server-&gt;code, $server-&gt;message, 'FROM', $server-&gt;quit);<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;delete
$self-&gt;{'connx_persist'}-&gt;{$chosenhost};<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;return
@retval;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; foreach
(@to)<br>
 &nbsp; &nbsp; &nbsp; &nbsp;{ &nbsp; &nbsp; next if $server-&gt;to($_);<br>
# must we be able to disable this?<br>
# next if $args{ignore_erroneous_destinations}<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;my
@retval=(0, $server-&gt;code, $server-&gt;message,&quot;To $_&quot;,$server-&gt;quit);<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;delete
$self-&gt;{'connx_persist'}-&gt;{$chosenhost};<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;return
@retval;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; $server-&gt;data;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;$server-&gt;datasend($_) foreach @header;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;my $bodydata = $message-&gt;body-&gt;file;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; if(ref
$bodydata eq 'GLOB') { $server-&gt;datasend($_) while &lt;$bodydata&gt;
}<br>
 &nbsp; &nbsp; &nbsp; &nbsp;else &nbsp; &nbsp;{ while(my $l = $bodydata-&gt;getline)
{ $server-&gt;datasend($l) } }</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; unless($server-&gt;dataend)<br>
 &nbsp; &nbsp; &nbsp; &nbsp;{<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;my
@retval=(0, $server-&gt;code, $server-&gt;message, 'DATA', $server-&gt;quit);<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;delete
$self-&gt;{'connx_persist'}-&gt;{$chosenhost};<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;return
@retval;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; return
(1, $server-&gt;code, $server-&gt;message, 'NOOP', $server-&gt;code);<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; #
in SCALAR context<br>
 &nbsp; &nbsp; &nbsp; &nbsp;return 0 unless $server;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; unless($server-&gt;mail($from))<br>
 &nbsp; &nbsp; &nbsp; &nbsp;{<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;$server-&gt;quit;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;delete
$self-&gt;{'connx_persist'}-&gt;{$chosenhost};<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;return
0;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; foreach
(@to)<br>
 &nbsp; &nbsp; &nbsp; &nbsp;{<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;next
if $server-&gt;to($_);<br>
# must we be able to disable this?<br>
# next if $args{ignore_erroneous_destinations}<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;$server-&gt;quit;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;delete
$self-&gt;{'connx_persist'}-&gt;{$chosenhost};<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;return
0;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; $server-&gt;data;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;$server-&gt;datasend($_) foreach @header;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;my $bodydata = $message-&gt;body-&gt;file;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; if(ref
$bodydata eq 'GLOB') { $server-&gt;datasend($_) while &lt;$bodydata&gt;
}<br>
 &nbsp; &nbsp; &nbsp; &nbsp;else &nbsp; &nbsp;{ while(my $l = $bodydata-&gt;getline)
{ $server-&gt;datasend($l) } }</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; unless($server-&gt;dataend)<br>
 &nbsp; &nbsp; &nbsp; &nbsp;{<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;$server-&gt;quit;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;delete $self-&gt;{'connx_persist'}-&gt;{$chosenhost};<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;return 0;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;}<br>
 &nbsp; &nbsp; &nbsp; &nbsp;1;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;# ELS Implicit unlock $self-&gt;{'connx_persist'}-&gt;{$chosenhost}
as exit scope;<br>
}</font>
<br>
<br><font size=1 face="Courier New">#------------------------------------------</font>
<br>
<br>
<br><font size=1 face="Courier New">sub contactAnyServer()<br>
{ &nbsp; my $self = shift;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; my ($enterval, $count,
$timeout) = $self-&gt;retry;<br>
 &nbsp; &nbsp;my ($host, $port, $username, $password) = $self-&gt;remoteHost;<br>
 &nbsp; &nbsp;my @hosts = ref $host ? @$host : $host;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; foreach my $host (@hosts)<br>
 &nbsp; &nbsp;{ &nbsp; my $server = $self-&gt;tryConnectTo<br>
 &nbsp; &nbsp; &nbsp; &nbsp; ( $host, Port =&gt; $port,<br>
 &nbsp; &nbsp; &nbsp; &nbsp; , %{$self-&gt;{MTS_net_smtp_opts}}, Timeout
=&gt; $timeout<br>
 &nbsp; &nbsp; &nbsp; &nbsp; );</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; defined
$server or next;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; $self-&gt;log(PROGRESS
=&gt; &quot;Opened SMTP connection to $host.&quot;);</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; if(defined
$username)<br>
 &nbsp; &nbsp; &nbsp; &nbsp;{ &nbsp; if($server-&gt;auth($username, $password))<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;{ &nbsp; &nbsp;$self-&gt;log(PROGRESS
=&gt; &quot;$host: Authentication succeeded.&quot;);<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;}<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;else<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;{ &nbsp; &nbsp;$self-&gt;log(ERROR
=&gt; &quot;Authentication failed.&quot;);<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; return undef;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;}<br>
 &nbsp; &nbsp; &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; return
$server;<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; undef;<br>
}</font>
<br>
<br><font size=1 face="Courier New">#------------------------------------------</font>
<br>
<br><font size=1 face="Courier New">sub contactAnyServer_persist()<br>
{ &nbsp; my $self = shift;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; my ($enterval, $count,
$timeout) = $self-&gt;retry;<br>
 &nbsp; &nbsp;my ($host, $port, $username, $password) = $self-&gt;remoteHost;<br>
 &nbsp; &nbsp;my @hosts = ref $host ? @$host : $host;</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; foreach my $host (@hosts)<br>
 &nbsp; &nbsp;{ &nbsp; my ($server);<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; if(exists($self-&gt;{'connx_persist'}-&gt;{$host}))
#ELS<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; {<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; $server=$self-&gt;{'connx_persist'}-&gt;{$host};<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; lock $self-&gt;{'connx_persist'}-&gt;{$host} if $server;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; unless ($server-&gt;reset)<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; {<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; delete($self-&gt;{'connx_persist'}-&gt;{$host});<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; next;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; }<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; # Implicit unlock $self-&gt;{'connx_persist'}-&gt;{$host}<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; }<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; else<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; {<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp;$server = $self-&gt;tryConnectTo<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; ( $host, Port =&gt; $port,<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; , %{$self-&gt;{MTS_net_smtp_opts}}, Timeout
=&gt; $timeout<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; );</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; defined $server or next;<br>
 &nbsp; &nbsp; &nbsp; &nbsp;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp;$self-&gt;log(PROGRESS =&gt; &quot;Opened SMTP
connection to $host.&quot;);<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp;if(defined $username)<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp;{ &nbsp; if($server-&gt;auth($username, $password))<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; &nbsp; &nbsp;{ &nbsp; &nbsp;$self-&gt;log(PROGRESS
=&gt; &quot;$host: Authentication succeeded.&quot;);<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; &nbsp; &nbsp;}<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; &nbsp; &nbsp;else<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; &nbsp; &nbsp;{ &nbsp; &nbsp;$self-&gt;log(ERROR
=&gt; &quot;Authentication failed.&quot;);<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; return undef;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; &nbsp; &nbsp;}<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp;}<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
$self-&gt;{'connx_persist'}-&gt;{$host}=$server;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; }<br>
 &nbsp; &nbsp; &nbsp; &nbsp;return ($server,$host);<br>
 &nbsp; &nbsp;}</font>
<br>
<br><font size=1 face="Courier New">&nbsp; &nbsp; undef;<br>
}</font>
<br>
<br><font size=1 face="Courier New">#------------------------------------------</font>
<br>
<br>
<br><font size=1 face="Courier New">sub tryConnectTo($@)<br>
{ &nbsp; my ($self, $host) = (shift, shift);<br>
 &nbsp; &nbsp;Net::SMTP-&gt;new($host, @_);<br>
}</font>
<br>
<br><font size=1 face="Courier New">#------------------------------------------</font>
<br>
<br><font size=1 face="Courier New">sub DESTROY($) &nbsp;#ELS<br>
{<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;my
$self=shift;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;foreach
my $connx (values %{$self-&gt;{'connx_persist'}})<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;{<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;
&nbsp; &nbsp; &nbsp; &nbsp;$connx-&gt;quit;<br>
 &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;}<br>
}</font>
<br>
<br>
<br><font size=1 face="Courier New">1;</font>
<br>
<br>
<br>
<br>
<br>
<br>
<br>
<table width=100%>
<tr valign=top>
<td width=40%><font size=1 face="sans-serif"><b>Eugene L Schulman/Edison/IBM</b>
</font>
<p><font size=1 face="sans-serif">06/03/2005 06:50 PM</font>
<td width=59%>
<table width=100%>
<tr>
<td>
<div align=right><font size=1 face="sans-serif">To</font></div>
<td valign=top><font size=1 face="sans-serif">[email protected]</font>
<tr>
<td>
<div align=right><font size=1 face="sans-serif">cc</font></div>
<td valign=top>
<tr>
<td>
<div align=right><font size=1 face="sans-serif">Subject</font></div>
<td valign=top><font size=1 face="sans-serif">Contribution- persistent
connection code for Mail::Transport::SMTP</font></table>
<br>
<table>
<tr valign=top>
<td>
<td></table>
<br></table>
<br>
<br>
<br><font size=3>&nbsp;</font>
<br>
<br></div>
--=_alternative 0080587585257015_=--