#=====================================================================
#   SMTP.pm : SMTP client module
#
#   Copyright(c) N.Oishi (BSC CONSULTING CGI-Laboratory).
#
#   e-mail : bigstone@my.email.ne.jp
#   support: http://www.din.or.jp/~bigstone/cgilab/index.html
#
#   THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND
#   ANY EXPRESS OR IMPLIED WARRANTIES ARE DISCLAIMED.
#
#   ver 1.0.2 : updated last on 2001/12/20
#
#=====================================================================
package SMTP;

use TCP;
use MIME;
use POP3Auth;

use strict;
use integer;
use vars qw($VERSION $CRLF_ANY $MAX_RECIPIENTS @SMTP_AUTH_MECH);

#---------------------------------------------------------------------
$MAX_RECIPIENTS = 100;
@SMTP_AUTH_MECH = ('CRAM-MD5', 'DIGEST-MD5', 'PLAIN', 'LOGIN');
#---------------------------------------------------------------------

$VERSION  = '1.0.2';
$CRLF_ANY = "\015?\012";

sub new {
    my $class = shift;
    my $self = {
        logs => [],
    };
    my($k, $v);
    while (($k, $v) = splice(@_, 0, 2)){
        $self->{lc($k)} = $v;
    }
    bless $self, ref $class || $class;
    if(defined $self->{host}){
        $self->_connect() || return undef;
    }
    return $self;
}

sub _connect {
    my $self = shift;
    if(my $v = $self->{pop_before_smtp}){
        $self->_pop3_auth($v) || return undef;
    }
    $self->{socket} = TCP->connect($self->{host}, $self->{port} || 25, $self->{timeout}) || return undef;
    my $debug = $self->{debug};
    $self->{debug} = 1;
    if($self->_command() != 2){
        $self->close();
        return undef;
    }
    ($self->{server}) = $self->{response} =~ /^\d\d\d.\s*(\S+)/o;
    unless($self->hello($self->{domain})){
        $self->quit();
        return undef;
    }
    if(my $v = $self->{smtp_auth}){
        unless($self->smtp_auth($v)){
            $self->quit();
            return undef;
        }
    }
    $self->{debug} = $debug;
    return $self;
}

sub hello {
    my $self   = shift;
    my $domain = shift || 'localhost';
    if($domain =~ /^\d+\.\d+\.\d+\.\d+$/o){
        $domain = '['. $domain .']';
    }
    $self->{esmtp} = {};
    if($self->_EHLO($domain)){
        my $response = $self->{response};
        $response =~ s/^[^\n]+\n//so;
        %{$self->{esmtp}} = map { /^\d\d\d[ \-](\S+)[ \t]*(.*)/ } split(/\n/, $response);
        return $self;
    }
    if(substr($self->{status}, 0, 1) == 5){
        return $self->_HELO($domain) ? $self : undef;
    }
    return undef;
}

sub mail {
    my $self = shift;
    my $addr = shift;
    my(%opts, $opt, $v);
    if(@_){
        %opts = ref($_[0]) eq 'HASH' ? %{$_[0]} : @{$_[0]};
        if($v = $opts{'RETURN'}){
            if(exists $self->{esmtp}->{'DSN'}){
                $opt .= ' RET='. uc($v);
            }
        }
        if($v = $opts{'8BITMIME'}){
            if(exists $self->{esmtp}->{'8BITMIME'}){
                $opt .= ' BODY=8BITMIME';
            }
        }
        if($v = $opts{'ENVID'}){
            if(exists $self->{esmtp}->{'DSN'}){
                $v =~ s/([^\041-\176]|=|\+)/sprintf("+%02x", ord($1))/esgo;
                $opt .= " ENVID=$v";
            }
        }
    }
    $self->_MAIL('FROM:<'. _get_addr($addr) .'>'. $opt);
}

sub mailto {
    shift->recipient(@_);
}

sub recipient {
    my $self = shift;
    my(%opts, $opt, $addr, $fail);
    if(ref($_[-1])){
        %opts = ref($_[-1]) eq 'HASH' ? %{pop(@_)} : @{pop(@_)};
    }
    return undef if @_ > 100;
    my $skip = $opts{'BADSKIP'};
    if(my $v = $opts{'NOTIFY'}){
        if(exists $self->{esmtp}->{'DSN'}){
            $opt = ' NOTIFY='. join(',', map { uc($_) } @{$v});
        }
    }
    my @sent = ();
    foreach $addr (@_){
        if($self->_RCPT('TO:<'. _get_addr($addr) .'>'. $opt)){
            push(@sent, $addr);
        } else {
            if(!$skip){ $fail = 1; last; }
        }
    }
    return undef if($fail || @sent == 0);
    return wantarray ? @sent : scalar @sent;
}

sub data {
    my $self = shift;
    $self->_DATA() || return undef;
    if(@_){
        $self->message(@_) || return undef;
        $self->data_end()  || return undef;
    }
    1;
}

sub message {
    my $self = shift;
    my $data = (@_ == 1 && ref($_[0])) ? $_[0] : \@_;
    foreach (@{$data}){
        s/($CRLF_ANY|^)\./$1../sgo;
        $self->_sendsock($_) || return undef;
    }
    1;
}

sub data_end {
    shift->_command("\n.\n") == 2;
}

sub etrn {
    my $self = shift;
    return undef unless(exists $self->{esmtp}->{'ETRN'});
    return $self->_ETRN() ? $self->{response} : undef;
}

sub expand {
    my $self = shift;
    return $self->_EXPN(@_) ? $self->{response} : undef;
}

sub help {
    my $self = shift;
    return $self->_HELP(@_) ? $self->{response} : undef;
}

sub reset {
    shift->_RSET();
}

sub send {
    shift->_SEND('FROM:<'. _get_addr($_[0]) .'>');
}

sub send_or_mail {
    shift->_SOML('FROM:<'. _get_addr($_[0]) .'>');
}

sub send_and_mail {
    shift->_SAML('FROM:<'. _get_addr($_[0]) .'>');
}

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

sub noop {
    shift->_NOOP();
}

sub quit {
    my $self = shift;
    my $cont = shift;
    my $status = $self->_QUIT();
    unless($cont){
        $self->close();
    }
    return $status;
}

sub close {
    my $self = shift;
    if(my $sock = delete $self->{socket}){
        $sock->close();
    }
}

sub esmtp {
    my $self = shift;
    return undef unless(defined $self->{esmtp});
    if(@_){
        return (exists $self->{esmtp}->{uc($_[0])});
    }
    return wantarray ? %{$self->{esmtp}} : $self->{esmtp};
}

sub server {
    shift->{server};
}

sub status {
    my $self = shift;
    return wantarray ? ($self->{status}, $self->{response}) : $self->{status};
}

sub is_success {
    my $self = shift;
    substr($self->{status}, 0, 1) == 2;
}

sub _get_addr {
    my $s = shift;
    $s =~ s/\n//go;
    $s =~ s/ *\"[^"]*\" *//go;
    $s =~ s/ *\([^)]*\) *//go;
    if($s =~ /< *([^>]+) *>/o){
        $s = $1;
    }
    $s =~ s/^ +//o;
    $s =~ s/ +$//o;
    $s;
}

#----------------------------------------------
#   Method of request to send a mail
#----------------------------------------------
sub request {
    my $self = shift;
    my(%parm, $k, $v);
    while (($k, $v) = splice(@_, 0, 2)){
        $parm{lc($k)} = $v;
    }
    my @recipient = ();
    foreach ('to', 'cc', 'bcc'){
        next unless $parm{$_};
        if(ref $parm{$_}){
            push(@recipient, @{$parm{$_}});
        } else {
            push(@recipient, split(/ *[,;] */, $parm{$_}));
        }
    }
    if(@recipient == 0 || @recipient > $MAX_RECIPIENTS){
        return undef;
    }
    return undef unless $parm{from};
    if(defined $parm{attach}){
        if(scalar keys(%{$parm{attach}}) == 0){
            delete $parm{attach};
        }
    }
    return undef unless($parm{content} || $parm{attach});
    delete $parm{bcc};
    delete $parm{dotskip};
    my $sock = $self->{socket} || return undef;
    my $mime = MIME->new(socket => $sock);
    my $sender = $parm{sender} || $parm{from};
    my $option = $parm{option} || {};
    my($success, @sent);
    while (1){
        $self->mail($sender, $option)     || last;
        if(@sent = $self->recipient(@recipient, $option)){
            $self->data()                 || last;
            $mime->encode_message(\%parm) || last;
            $self->data_end()             || last;
            $self->quit(1)                || last;
            $success = 1;
        } else {
            $self->quit(1);
        }
        last;
    }
    $self->close();
    return undef unless $success;
    return wantarray ? @sent : scalar @sent;
}

#----------------------------------------------
#   Wrapper methods for Socket I/O
#----------------------------------------------
sub _command {
    my $self = shift;
    my $cmd  = shift;
    $self->{status} = '000';
    if($cmd){
        $cmd  = join(' ', $cmd, @_) if @_;
        $cmd .= "\n" unless($cmd =~ /\n$/so);
        push(@{$self->{logs}}, $cmd) if $self->{debug};
        $self->_sendsock($cmd) || return undef;
    }
    ($self->{status}, $self->{response}) = $self->_recvsock();
    push(@{$self->{logs}}, $self->{response}) if $self->{debug};
    return substr($self->{status}, 0, 1);
}

sub _sendsock {
    my $self = shift;
    my $sock = $self->{socket} || return undef;
    unless($sock->write(@_)){
        die "Can't send message to socket." if $self->{debug};
        return undef;
    }
    1;
}

sub _recvsock {
    my $sock = shift->{socket} || return undef;
    my($code, $cont);
    my $res = "";
    while ($_ = $sock->read()){
        $res .= $_;
        ($code, $cont) = /^(\d\d\d)(.?)/o;
        last if $cont ne '-';
    }
    $res =~ s/$CRLF_ANY/\n/sgo;
    return wantarray ? ($code, $res) : $res;
}

#----------------------------------------------
#   Supported SMTP commands (RFC2821)
#----------------------------------------------
sub _EHLO { shift->_command('EHLO', @_) == 2; }
sub _EXPN { shift->_command('EXPN', @_) == 2; }
sub _HELO { shift->_command('HELO', @_) == 2; }
sub _HELP { shift->_command('HELP', @_) == 2; }
sub _MAIL { shift->_command('MAIL', @_) == 2; }
sub _RCPT { shift->_command('RCPT', @_) == 2; }
sub _SEND { shift->_command('SEND', @_) == 2; }
sub _SAML { shift->_command('SAML', @_) == 2; }
sub _SOML { shift->_command('SOML', @_) == 2; }
sub _VRFY { shift->_command('VRFY', @_) == 2; }
sub _DATA { shift->_command('DATA')     == 3; }
sub _ETRN { shift->_command('ETRN')     == 2; }
sub _NOOP { shift->_command('NOOP')     == 2; }
sub _RSET { shift->_command('RSET')     == 2; }
sub _QUIT { shift->_command('QUIT')     == 2; }

#----------------------------------------------
#   SMTP Authentication support
#----------------------------------------------
sub smtp_auth {
    my $self = shift;
    return undef unless defined $self->{esmtp}->{AUTH};
    my($parm, $user, $pass, $auth, @auth, $k, $v);
    if(ref($_[0]) eq 'HASH'){
        $parm = shift;
    } else {
        $parm = {}; %{$parm} = @_;
    }
    while (($k, $v) = each %{$parm}){
        $k = lc($k);
        if($k eq 'user'){ $user = $v; next; }
        if($k eq 'pass'){ $pass = $v; next; }
        if($k eq 'auth'){ @auth = @{$v}; next; }
    }
    my @mech = map { uc($_) } split(/[\t ]+/, $self->{esmtp}->{AUTH});
    @auth = @SMTP_AUTH_MECH unless @auth;
    $k = undef;
    foreach $v (@auth){
        if(grep($v eq $_, @mech)){
            $k = $v; last;
        }
    }
    return undef unless $k;
    if($k eq 'CRAM-MD5'){
        $auth = $self->auth_cram_md5($user, $pass);
    } elsif($k eq 'DIGEST-MD5'){
        $auth = $self->auth_digest_md5($user, $pass);
    } elsif($k eq 'PLAIN'){
        $auth = $self->auth_plain($user, $pass);
    } elsif($k eq 'LOGIN'){
        $auth = $self->auth_login($user, $pass);
    } elsif($self->{debug}){
        die "Unsupported SMTP AUTH mechanism '$k'";
    }
    return $auth;
}

sub auth_plain {
    my $self = shift;
    my $user = shift;
    my $pass = shift;
    $user =~ s/\@.+$//o;
    $self->_command('AUTH PLAIN', encode_base64("\0$user\0$pass", "")) == 2;
}

sub auth_login {
    my $self = shift;
    my $user = shift;
    my $pass = shift;
    $user =~ s/\@.+$//o;
    $self->_command('AUTH LOGIN', encode_base64($user, "")) == 3 &&
    $self->_command(encode_base64($pass, "")) == 2;
}

sub _require_md5 {
    my $self = shift;
    eval {
        require Digest::MD5; Digest::MD5->import(qw(md5 md5_hex));
    };
    if($@){
        if($self->{debug}){
            die "You need to install Digest-MD5 to use the MD5 auth mechanisms.";
        }
        return undef;
    }
    1;
}

sub auth_cram_md5 {
    my $self = shift;
    my $user = shift;
    my $pass = shift;
    $self->_require_md5() || return undef;
    $self->_command('AUTH CRAM-MD5') == 3 || return undef;
    my($challenge) = $self->{response} =~ m! +([A-Za-z0-9+/]+=*)!o;
    my $response = _hmac_md5($pass, decode_base64($challenge));
    $self->_command(encode_base64("$user $response", "")) == 2;
}

sub _hmac_md5 {
    my $pass = shift;
    my $ckey = shift;
    my $size = 64;
    $pass = md5($pass) if length($pass) > $size;
    my $ipad = $pass ^ (chr(0x36) x $size);
    my $opad = $pass ^ (chr(0x5c) x $size);
    return md5_hex($opad, md5($ipad, $ckey));
}

sub auth_digest_md5 {
    my $self = shift;
    my $user = shift;
    my $pass = shift;
    $self->_require_md5() || return undef;
    $self->_command('AUTH DIGEST-MD5') == 3 || return undef;
    my($challenge) = $self->{response} =~ m! +([A-Za-z0-9+/]+=*)!o;
    my $response = $self->_digest_md5($user, $pass, decode_base64($challenge));
    my $status = $self->_command(encode_base64($response, ""));
    if($status == 3){
        $status = $self->_command("\n");
    }
    $status == 2;
}

sub _digest_md5 {
    my $self = shift;
    my $user = shift;
    my $pass = shift;
    my %ckey = map { /^([^=]+)="?(.+?)"?$/ } split(/,/, $_[0]);
    my $realm  = ($user =~ s/\@(.+)$//o) ? $1 : $self->{server};
    my $nonce  = $ckey{nonce};
    my $cnonce = _rand_string(14);
    my $uri = join('/', 'smtp', $self->{host}, $self->{server});
    my $qop = 'auth';
    my $nc  = '00000001';
    my($hv, $a1, $a2);
    $hv = md5("$user:$realm:$pass");
    $a1 = md5_hex("$hv:$nonce:$cnonce");
    $a2 = md5_hex("AUTHENTICATE:$uri");
    $hv = md5_hex("$a1:$nonce:$nc:$cnonce:$qop:$a2");
    return qq(username="$user",realm="$realm",nonce="$nonce",nc=$nc,cnonce="$cnonce",digest-uri="$uri",response=$hv,qop=$qop);
}

sub _rand_string {
    my $size = shift || 8;
    my $len  = int($size * 3 / 4) + 1;
    my $s = encode_base64(join('', map chr(rand(256)), 1..$len), "");
    $s =~ s/[\W]/X/go;
    substr($s, 0, $size);
}

#----------------------------------------------
#   POP before SMTP support
#----------------------------------------------
sub _pop3_auth {
    my $self = shift;
    my $parm = shift;
    my($host, $port, $user, $pass, $apop, $k, $v);
    while (($k, $v) = each %{$parm}){
        $k = lc($k);
        if($k eq 'host'){ $host = $v; next; }
        if($k eq 'port'){ $port = $v; next; }
        if($k eq 'user'){ $user = $v; next; }
        if($k eq 'pass'){ $pass = $v; next; }
        if($k eq 'apop'){ $apop = $v; next; }
    }
    return undef unless $user;
    my $pop3 = POP3Auth->new(
        host    => $host || $self->{host},
        port    => $port,
        timeout => $self->{timeout} || 0,
    ) || return undef;
    my $status = $apop ? $pop3->apop($user, $pass) : $pop3->login($user, $pass);
    $pop3->quit();
    $status;
}

#----------------------------------------------
#   Debug option support
#----------------------------------------------
sub debug {
    my $self = shift;
    if(@_){
        $self->{debug} = shift;
        if($self->{debug} == -1){
            $self->{logs} = [];
        }
    } else {
        return wantarray ? @{$self->{logs}} : $self->{logs};
    }
}

1;

__END__