File Coverage

blib/lib/Net/LMTP.pm

Criterion	Covered	Total	%
statement	18	171	10.5
branch	0	82	0.0
condition	0	25	0.0
subroutine	6	42	14.2
pod	17	18	94.4
total	41	338	12.1

# Net::LMTP.pm
#
# Copyright (c) 2001 Les Howard .  This module
# is directly derived from the Net::SMTP module.  All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::LMTP;

require 5.001;

use strict;
use vars qw($VERSION @ISA);
use Socket 1.3;
use Carp;
use IO::Socket;
use Net::Cmd;

$VERSION = "0.02"; # $Id$

@ISA = qw(Net::Cmd IO::Socket::INET);

sub new
{
 my $self = shift;
 my $type = ref($self) || $self;
 my $host = shift;
 my $port = shift;
 my %arg  = @_;
 my $obj;

 if(!defined $host){
   warn "Net::LMTP:new - no host specified\n";
   return undef;
 }
 if(!defined $port){
   warn "Net::LMTP:new - no port specified\n";
   return undef;
 }

 $obj = $type->SUPER::new(PeerAddr => ($host = $host),
			    PeerPort => $port,
			    Proto    => 'tcp',
			    Timeout  => defined $arg{Timeout}
						? $arg{Timeout}
						: 120
			   );
 $obj->autoflush(1);

 $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);

 unless ($obj->response() == CMD_OK)
  {
   $obj->close();
   return undef;
  }

 ${*$obj}{'net_lmtp_host'} = $host;

 (${*$obj}{'net_lmtp_banner'}) = $obj->message;
 (${*$obj}{'net_lmtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;

 unless($obj->hello($arg{Hello} || ""))
  {
   $obj->close();
   return undef;
  }

 $obj;
}

##
## User interface methods
##

sub banner
{
 my $me = shift;

 return ${*$me}{'net_lmtp_banner'} || undef;
}

sub domain
{
 my $me = shift;

 return ${*$me}{'net_lmtp_domain'} || undef;
}

sub etrn {
    my $self = shift;
    defined($self->supports('ETRN',500,["Command unknown: 'ETRN'"])) &&
	$self->_ETRN(@_);
}

sub hello
{
 my $me = shift;
 my $domain = shift ||
	      eval {
		    require Net::Domain;
		    Net::Domain::hostfqdn();
		   } ||
		"";
 my $ok = $me->_LHLO($domain);
 my @msg = $me->message;

 if($ok)
  {
   my $h = ${*$me}{'net_lmtp_lmtp'} = {};
   my $ln;
   foreach $ln (@msg) {
     $h->{$1} = $2
	if $ln =~ /(\S+)\b[ \t]*([^\n]*)/;
    }
  }

 $ok && $msg[0] =~ /\A(\S+)/
	? $1
	: undef;
}

sub supports {
    my $self = shift;
    my $cmd = uc shift;
    return ${*$self}{'net_lmtp_lmtp'}->{$cmd}
	if exists ${*$self}{'net_lmtp_lmtp'}->{$cmd};
    $self->set_status(@_)
	if @_;
    return;
}

sub _addr
{
 my $addr = shift || "";

 return $1
    if $addr =~ /(<[^>]+>)/so;

 $addr =~ s/\n/ /sog;
 $addr =~ s/(\A\s+|\s+\Z)//sog;

 return "<" . $addr . ">";
}


sub mail
{
 my $me = shift;
 my $addr = _addr(shift);
 my $opts = "";

 if(@_)
  {
   my %opt = @_;
   my($k,$v);

   if(exists ${*$me}{'net_lmtp_lmtp'})
    {
     my $lmtp = ${*$me}{'net_lmtp_lmtp'};

     if(defined($v = delete $opt{Size}))
      {
       if(exists $lmtp->{SIZE})
        {
         $opts .= sprintf " SIZE=%d", $v + 0
        }
       else
        {
	 carp 'Net::LMTP::mail: SIZE option not supported by host';
        }
      }

     if(defined($v = delete $opt{Return}))
      {
       if(exists $lmtp->{DSN})
        {
	 $opts .= " RET=" . uc $v
        }
       else
        {
	 carp 'Net:::LMTP::mail: DSN option not supported by host';
        }
      }

     if(defined($v = delete $opt{Bits}))
      {
       if(exists $lmtp->{'8BITMIME'})
        {
	 $opts .= $v == 8 ? " BODY=8BITMIME" : " BODY=7BIT"
        }
       else
        {
	 carp 'Net::LMTP::mail: 8BITMIME option not supported by host';
        }
      }

     if(defined($v = delete $opt{Transaction}))
      {
       if(exists $lmtp->{CHECKPOINT})
        {
	 $opts .= " TRANSID=" . _addr($v);
        }
       else
        {
	 carp 'Net::LMTP::mail: CHECKPOINT option not supported by host';
        }
      }

     if(defined($v = delete $opt{Envelope}))
      {
       if(exists $lmtp->{DSN})
        {
	 $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
	 $opts .= " ENVID=$v"
        }
       else
        {
	 carp 'Net::LMTP::mail: DSN option not supported by host';
        }
      }

     carp 'Net::LMTP::recipient: unknown option(s) '
		. join(" ", keys %opt)
		. ' - ignored'
	if scalar keys %opt;
    }
   else
    {
     carp 'Net::LMTP::mail: LMTP not supported by host - options discarded :-(';
    }
  }

 $me->_MAIL("FROM:".$addr.$opts);
}

sub send	  { shift->_SEND("FROM:" . _addr($_[0])) }
sub send_or_mail  { shift->_SOML("FROM:" . _addr($_[0])) }
sub send_and_mail { shift->_SAML("FROM:" . _addr($_[0])) }

sub reset
{
 my $me = shift;

 $me->dataend()
	if(exists ${*$me}{'net_lmtp_lastch'});

 $me->_RSET();
}


sub recipient
{
 my $lmtp = shift;
 my $opts = "";
 my $skip_bad = 0;

 if(@_ && ref($_[-1]))
  {
   my %opt = %{pop(@_)};
   my $v;

   $skip_bad = delete $opt{'SkipBad'};

   if(exists ${*$lmtp}{'net_lmtp_lmtp'})
    {
     my $lmtp = ${*$lmtp}{'net_lmtp_lmtp'};

     if(defined($v = delete $opt{Notify}))
      {
       if(exists $lmtp->{DSN})
        {
	 $opts .= " NOTIFY=" . join(",",map { uc $_ } @$v)
        }
       else
        {
	 carp 'Net::LMTP::recipient: DSN option not supported by host';
        }
      }

     carp 'Net::LMTP::recipient: unknown option(s) '
		. join(" ", keys %opt)
		. ' - ignored'
	if scalar keys %opt;
    }
   elsif(%opt)
    {
     carp 'Net::LMTP::recipient: LMTP not supported by host - options discarded :-(';
    }
  }

 my @ok;
 my $addr;
 foreach $addr (@_)
  {
    if($lmtp->_RCPT("TO:" . _addr($addr) . $opts)) {
      push(@ok,$addr) if $skip_bad;
    }
    elsif(!$skip_bad) {
      return 0;
    }
  }

 return $skip_bad ? @ok : 1;
}

sub to { shift->recipient(@_) }

sub data
{
 my $me = shift;

 my $ok = $me->_DATA() && $me->datasend(@_);

 $ok && @_ ? $me->dataend
	   : $ok;
}

sub expand
{
 my $me = shift;

 $me->_EXPN(@_) ? ($me->message)
		: ();
}


sub verify { shift->_VRFY(@_) }

sub help
{
 my $me = shift;

 $me->_HELP(@_) ? scalar $me->message
	        : undef;
}

sub quit
{
 my $me = shift;

 $me->_QUIT;
 $me->close;
}

sub DESTROY
{
# ignore
}

##
## SMTP commands that remain in LMTP
##

sub _MAIL { shift->command("MAIL", @_)->response()  == CMD_OK }
sub _RCPT { shift->command("RCPT", @_)->response()  == CMD_OK }
sub _SEND { shift->command("SEND", @_)->response()  == CMD_OK }
sub _SAML { shift->command("SAML", @_)->response()  == CMD_OK }
sub _SOML { shift->command("SOML", @_)->response()  == CMD_OK }
sub _VRFY { shift->command("VRFY", @_)->response()  == CMD_OK }
sub _EXPN { shift->command("EXPN", @_)->response()  == CMD_OK }
sub _HELP { shift->command("HELP", @_)->response()  == CMD_OK }
sub _RSET { shift->command("RSET")->response()	    == CMD_OK }
sub _NOOP { shift->command("NOOP")->response()	    == CMD_OK }
sub _QUIT { shift->command("QUIT")->response()	    == CMD_OK }
sub _DATA { shift->command("DATA")->response()	    == CMD_MORE }
sub _TURN { shift->unsupported(@_); }
sub _ETRN { shift->command("ETRN", @_)->response()  == CMD_OK }


##
## RFC2033 commands
##
sub _LHLO { shift->command("LHLO", @_)->response()  == CMD_OK }
sub _BDAT { shift->unsupported(@_); }

1;

__END__